• Pesquisa na Web

Private WithEvents olInboxItems As Items

Private Sub Application_Startup()
 

   Dim objNS As NameSpace
   Set objNS = Application.GetNamespace("MAPI")
   Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
   Set objNS = Nothing
 

End Sub

Private Sub Application_Quit()
 

   Set olInboxItems = Nothing
 

End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

   Dim objAttFld As MAPIFolder
   Dim objInbox As MAPIFolder
   Dim objNS As NameSpace
   Dim strAttFldName As String
   Dim strProgExt As String
   Dim arrExt() As String
   Dim objAtt As Attachment
   Dim intPos As Integer
   Dim I As Integer
   Dim strExt As String

' #### OPÇÕES UTILIZADOR ####
' nome da subpasta dentro da Inbox para guardar os anexos

strAttFldName = "Quarentena"

' lista de extensões que se pretende apanhar (devem ser separadas por virgula)

strProgExt = "exe, bat, com, vbs, vbe"

On Error Resume Next

Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objAttFld = objInbox.Folders(strAttFldName)

   If Item.Class = olMail Then
      If objAttFld Is Nothing Then
      ' cria a pasta se fôr preciso
      Set objAttFld = objInbox.Folders.Add(strAttFldName)
   End If

If Not objAttFld Is Nothing Then
   ' converte a lista das extensões numa array
      arrExt = Split(strProgExt, ",")
 

      For Each objAtt In Item.Attachments
         intPos = InStrRev(objAtt.FileName, ".")
           If intPos > 0 Then
            ' verifica as extensões do anexo contra a array
           strExt = LCase(Mid(objAtt.FileName, intPos + 1))
           For I = LBound(arrExt) To UBound(arrExt)
              If strExt = Trim(arrExt(I)) Then
                 Item.Move objAttFld
              Exit For
           End If
      Next
 Else
   ' se não há extensões; tipo desconhecido
       Item.Move objAttFld
   End If
    Next
 End If
End If

On Error GoTo 0

Set objAttFld = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objAtt = Nothing

End Sub

Public Sub EmptyJunkEmailFolder()

Dim outapp As Outlook.Application
Dim olitem As Object
Dim fldJunk As Outlook.MAPIFolder

Set outapp = CreateObject("outlook.application")
Set fldJunk = outapp.GetNamespace("MAPI").GetDefaultFolder(olFolderJunk)
  For Each olitem In fldJunk.Items
    olitem.Delete
  Next

Set fldJunk = Nothing
Set olitem = Nothing
Set outapp = Nothing

End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMe As Recipient
 

Set objMe = Item.Recipients.Add("myaddress@mydomain.dom") 'altera o endereço para o pretendido
   objMe.Type = olBCC
   objMe.Resolve
 

Set objMe = Nothing
End Sub

Sub StampContact()
Dim objApp As Application
Dim objItem As Object
Dim objNS As NameSpace

Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objItem = objApp.ActiveInspector.CurrentItem
 

If objItem.Class = olContact Then
   objItem.Body = objItem.Body & vbCrLf & Now() & " - " & objNS.CurrentUser
End If

Set objItem = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Sub

Sub sendfromWord()

resposta = MsgBox("Vai enviar uma mensagem de correio electrónico com o Word. Deseja continuar ?", vbYesNo + vbQuestion)

If resposta = vbYes Then ActiveDocument.Save

Dim bStarted As Boolean

Dim oOutlookApp As Outlook.Application

Dim oItem As Outlook.MailItem

On Error Resume Next

If Len(ActiveDocument.Path) = 0 Then

   MsgBox "O documento tem de ser guardado em primeiro lugar"

   Exit Sub

End If

Set oOutlookApp = GetObject(, "Outlook.Application")

If Err <> 0 Then

  Set oOutlookApp = CreateObject("Outlook.Application")

  bStarted = True

End If

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem

  .To = "teste@teste.pt" 'mudar endereço

  .Subject = "Enviar documento word"

  .Attachments.Add Source:=ActiveDocument.FullName, Type:=olByValue, DisplayName:="Documento anexado"

  .Send

End With

If bStarted Then

oOutlookApp.Quit

End If

Set oItem = Nothing

Set oOutlookApp = Nothing

Else

End If

End Sub

Option Explicit

Const CdoE_ACCESSDENIED = 80070005

Public Const CdoPR_EMAIL = &H39FE001E

Sub SaveEmailsToWord()

On Error GoTo ErrorHandler

   Dim appword As Word.Application

   Dim strTemplatePath As String

   Dim i As Integer

   Dim lngCount As Long

   Dim nms As Outlook.NameSpace

   Dim fld As Outlook.MAPIFolder

   Dim itm As Object

   Dim oNewDoc As Word.Document

   Dim WordWasNotRunning As Boolean

   On Error Resume Next

    Set appword = GetObject(, "Word.Application")

    If Err Then

    Set appword = New Word.Application

    WordWasNotRunning = True

    End If

    appword.Visible = True

    Set oNewDoc = appword.Documents.Add(Template:="normal.dot")

   Set nms = Application.GetNamespace("MAPI")

   Set fld = nms.PickFolder

   If fld Is Nothing Then

      GoTo ErrorHandlerExit

   End If

   If fld.DefaultItemType <> olMailItem Then

      MsgBox "Folder does not contain messages"

      GoTo ErrorHandlerExit

   End If

   lngCount = fld.Items.Count

   If lngCount = 0 Then

      MsgBox "No Messages to export"

      GoTo ErrorHandlerExit

   Else

      Debug.Print lngCount & " Messages to export"

   End If

   For Each itm In fld.Items

      If itm.Class = olMail Then

        oNewDoc.Range.Text = oNewDoc.Range.Text & "Subject: " & itm.Subject

        oNewDoc.Range.Text = oNewDoc.Range.Text & "Received: " & itm.ReceivedTime

        oNewDoc.Range.Text = oNewDoc.Range.Text & "From: " & GetFromAddress(itm)

        oNewDoc.Range.Text = oNewDoc.Range.Text & "Body: " & itm.Body

        On Error Resume Next

      End If

   Next itm

ErrorHandlerExit:

   Exit Sub

ErrorHandler:

   If Err.Number = 429 Then

      If appword Is Nothing Then

         Set appword = CreateObject("word.Application")

         Resume Next

      End If

   Else

      MsgBox "Error No: " & Err.Number & "; Description: "

      Resume ErrorHandlerExit

   End If

End Sub

Sub ShowAddresses()

    Dim obj As Object

    Set obj = GetCurrentItem()

    If obj.Class = olMail Then

        MsgBox "Email address is: " & GetFromAddress(obj)

    End If

    Set obj = Nothing

End Sub

Function GetFromAddress(objMsg As Outlook.MailItem)

    Dim objSession As MAPI.Session

    Dim objCDOMsg As MAPI.Message

    Dim strEntryID As String

    Dim strStoreID As String

    Dim strAddress As String

    Dim straddress1 As String

    ' start CDO session

    Set objSession = CreateObject("MAPI.Session")

    objSession.Logon , , False, False

    ' pass message to CDO

    strEntryID = objMsg.EntryID

    strStoreID = objMsg.Parent.StoreID

    Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)

    ' get sender address

    On Error Resume Next

    strAddress = objCDOMsg.Sender.Address

    If Err = CdoE_ACCESSDENIED Then

        'handle possible security patch error

        MsgBox "The Outlook E-mail and CDO Security Patches are " & _

               "apparently installed on this machine. " & _

               "You must response Yes to the prompt about " & _

               "accessing e-mail addresses if you want to " & _

               "get the From address.", vbExclamation, _

                "GetFromAddress"

    End If

    GetFromAddress = strAddress

    On Error GoTo 0

    Set objCDOMsg = Nothing

    objSession.Logoff

    Set objSession = Nothing

End Function

Option Explicit

Const CdoE_ACCESSDENIED = 80070005

Public Const CdoPR_EMAIL = &H39FE001E

Sub SaveEmailsToExcel()

On Error GoTo ErrorHandler

   Dim appExcel As Excel.Application

   Dim wkb As Excel.Workbook

   Dim wks As Excel.Worksheet

   Dim rng As Excel.Range

   Dim strRange As String

   Dim strSheet As String

   Dim strbook As Workbook

   Dim lngASCII As Long

   Dim strASCII As String

   Dim strTemplatePath As String

   Dim i As Integer

   Dim lngCount As Long

   Dim nms As Outlook.NameSpace

   Dim fld As Outlook.MAPIFolder

   Dim itm As Object

   'Pick up Template path from the Word Options dialog

   strTemplatePath = "D:\"

   'Debug.Print "Documents folder: " & strTemplatePath

   strSheet = "export.xls"

   strSheet = strTemplatePath & strSheet

   Debug.Print "Excel workbook: " & strSheet

   i = 1

   lngASCII = 64

   Set appExcel = GetObject(, "Excel.Application")

   appExcel.Workbooks.Open (strSheet)

   Set wkb = appExcel.ActiveWorkbook

   Set wks = wkb.Sheets(1)

   wks.cells(1, 1) = "Subject"

   wks.cells(1, 2) = "Received"

   wks.cells(1, 3) = "From"

   wks.cells(1, 4) = "Body"

   wks.Activate

   appExcel.Application.Visible = True

   Set nms = Application.GetNamespace("MAPI")

   Set fld = nms.PickFolder

   If fld Is Nothing Then

      GoTo ErrorHandlerExit

   End If

   If fld.DefaultItemType <> olMailItem Then

      MsgBox "Folder does not contain messages"

      GoTo ErrorHandlerExit

   End If

   lngCount = fld.Items.Count

   If lngCount = 0 Then

      MsgBox "No Messages to export"

      GoTo ErrorHandlerExit

   Else

      Debug.Print lngCount & " Messages to export"

   End If

   For Each itm In fld.Items

      If itm.Class = olMail Then

         i = i + 1

         lngASCII = lngASCII + 1

         strASCII = Chr(lngASCII)

         strRange = strASCII & CStr(i)

         Set rng = wks.Range(strRange)

         If itm.Subject <> "" Then rng.Value = itm.Subject

         lngASCII = lngASCII + 1

         strASCII = Chr(lngASCII)

         strRange = strASCII & CStr(i)

         Set rng = wks.Range(strRange)

         If itm.ReceivedTime <> "" Then rng.Value = itm.ReceivedTime

         lngASCII = lngASCII + 1

         strASCII = Chr(lngASCII)

         strRange = strASCII & CStr(i)

         Set rng = wks.Range(strRange)

         If GetFromAddress(itm) <> "" Then rng.Value = GetFromAddress(itm)

         lngASCII = lngASCII + 1

         strASCII = Chr(lngASCII)

         strRange = strASCII & CStr(i)

         Set rng = wks.Range(strRange)

         If itm.Body <> "" Then rng.Value = itm.Body

         On Error Resume Next

         'The next line illustrates the syntax for referencing

         'a custom Outlook field

         'If itm.UserProperties("CustomField") <> "" Then

         '   rng.Value = itm.UserProperties("CustomField")

         'End If

         lngASCII = 64

      End If

   Next itm

ErrorHandlerExit:

   Exit Sub

ErrorHandler:

   If Err.Number = 429 Then

      If appExcel Is Nothing Then

         Set appExcel = CreateObject("Excel.Application")

         Resume Next

      End If

   Else

      MsgBox "Error No: " & Err.Number & "; Description: "

      Resume ErrorHandlerExit

   End If

End Sub

Sub ShowAddresses()

    Dim obj As Object

    Set obj = GetCurrentItem()

    If obj.Class = olMail Then

        MsgBox "Email address is: " & GetFromAddress(obj)

    End If

    Set obj = Nothing

End Sub

Function GetFromAddress(objMsg As Outlook.MailItem)

    Dim objSession As MAPI.Session

    Dim objCDOMsg As MAPI.Message

    Dim strEntryID As String

    Dim strStoreID As String

    Dim strAddress As String

    Dim straddress1 As String

    ' start CDO session

    Set objSession = CreateObject("MAPI.Session")

    objSession.Logon , , False, False

    ' pass message to CDO

    strEntryID = objMsg.EntryID

    strStoreID = objMsg.Parent.StoreID

    Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)

    ' get sender address

    On Error Resume Next

    strAddress = objCDOMsg.Sender.Address

    If Err = CdoE_ACCESSDENIED Then

        'handle possible security patch error

        MsgBox "The Outlook E-mail and CDO Security Patches are " & _

               "apparently installed on this machine. " & _

               "You must response Yes to the prompt about " & _

               "accessing e-mail addresses if you want to " & _

               "get the From address.", vbExclamation, _

                "GetFromAddress"

    End If

    GetFromAddress = strAddress

    On Error GoTo 0

    Set objCDOMsg = Nothing

    objSession.Logoff

    Set objSession = Nothing

End Function

Option Explicit

Const CdoE_ACCESSDENIED = 80070005

Public Const CdoPR_EMAIL = &H39FE001E

Sub SaveEmailsToAccess()

On Error GoTo ErrorHandler

   Dim appaccess As Access.Application

   Dim dbs As Database

   Dim rst As Recordset

   Dim i As Integer

   Dim lngCount As Long

   Dim nms As Outlook.NameSpace

   Dim fld As Outlook.MAPIFolder

   Dim itm As Object

   On Error Resume Next

   Set nms = Application.GetNamespace("MAPI")

   Set fld = nms.PickFolder

   If fld Is Nothing Then

      GoTo ErrorHandlerExit

   End If

   If fld.DefaultItemType <> olMailItem Then

      MsgBox "Folder does not contain messages"

      GoTo ErrorHandlerExit

   End If

   lngCount = fld.Items.Count

   If lngCount = 0 Then

      MsgBox "No Messages to export"

      GoTo ErrorHandlerExit

   Else

      Debug.Print lngCount & " Messages to export"

   End If

   For Each itm In fld.Items

      If itm.Class = olMail Then

                Set dbs = OpenDatabase("D:\database.mdb")

                Set rst = dbs.OpenRecordset("mails2access")

                rst.AddNew

                rst!Subject = itm.Subject

                rst!Received = itm.ReceivedTime

                rst!From = GetFromAddress(itm)

                rst!Body = itm.Body

                'rst2.customfield = itm.UserProperties("Custom Field Name")

                rst.Update

                rst.Close

        On Error Resume Next

      End If

   Next itm

ErrorHandlerExit:

   Exit Sub

ErrorHandler:

   If Err.Number = 429 Then

      If appaccess Is Nothing Then

         Set appaccess = CreateObject("Access.Application")

         Resume Next

      End If

   Else

      MsgBox "Error No: " & Err.Number & "; Description: "

      Resume ErrorHandlerExit

   End If

End Sub

Sub ShowAddresses()

    Dim obj As Object

    Set obj = GetCurrentItem()

    If obj.Class = olMail Then

        MsgBox "Email address is: " & GetFromAddress(obj)

    End If

    Set obj = Nothing

End Sub

Function GetFromAddress(objMsg As Outlook.MailItem)

    Dim objSession As MAPI.Session

    Dim objCDOMsg As MAPI.Message

    Dim strEntryID As String

    Dim strStoreID As String

    Dim strAddress As String

    Dim straddress1 As String

    ' start CDO session

    Set objSession = CreateObject("MAPI.Session")

    objSession.Logon , , False, False

    ' pass message to CDO

    strEntryID = objMsg.EntryID

    strStoreID = objMsg.Parent.StoreID

    Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)

    ' get sender address

    On Error Resume Next

    strAddress = objCDOMsg.Sender.Address

    If Err = CdoE_ACCESSDENIED Then

        'handle possible security patch error

        MsgBox "The Outlook E-mail and CDO Security Patches are " & _

               "apparently installed on this machine. " & _

               "You must response Yes to the prompt about " & _

               "accessing e-mail addresses if you want to " & _

               "get the From address.", vbExclamation, _

                "GetFromAddress"

    End If

    GetFromAddress = strAddress

    On Error GoTo 0

    Set objCDOMsg = Nothing

    objSession.Logoff

    Set objSession = Nothing

End Function

Sub InsertMySig()
Call InsertSig("Nome da assinatura")
End Sub

'onde "Nome da assinatura" tem que ser igual ao que aparece nos menus e caixas de diálogo.

Sub InsertSig(strSigName As String)
Dim objItem As Object
Dim objInsp As Outlook.Inspector
' Referência ao Microsoft Word
Dim objDoc As Word.Document
Dim objSel As Word.Selection
' Referência ao Microsoft Office
Dim objCB As Office.CommandBar
Dim objCBP As Office.CommandBarPopup
Dim objCBB As Office.CommandBarButton
Dim colCBControls As Office.CommandBarControls
On Error Resume Next

Set objInsp = Application.ActiveInspector
If Not objInsp Is Nothing Then
Set objItem = objInsp.CurrentItem
If objItem.Class = olMail Then ' editor is WordMail
If objInsp.EditorType = olEditorWord Then
' A próxima opção vai activar a caixa de diálogo de segurança do Outlook 2002 SP3
Set objDoc = objInsp.WordEditor
Set objSel = objDoc.Application.Selection
If objDoc.Bookmarks("_MailAutoSig") Is Nothing Then
objDoc.Bookmarks.Add Range:=objSel.Range, Name:="_MailAutoSig"
End If
objSel.GoTo What:=wdGoToBookmark, Name:="_MailAutoSig"
Set objCB = objDoc.CommandBars("AutoSignature Popup")
If Not objCB Is Nothing Then
Set colCBControls = objCB.Controls
End If
Else ' se o editor não for o WordMail
' Acede ao menu Insert | Signature
Set objCBP = Application.ActiveInspector.CommandBars.FindControl(, 31145)
If Not objCBP Is Nothing Then
Set colCBControls = objCBP.Controls
End If
End If
End If
If Not colCBControls Is Nothing Then
For Each objCBB In colCBControls
If objCBB.Caption = strSigName Then
objCBB.Execute
Exit For
End If
Next
End If
End If

Set objInsp = Nothing
Set objItem = Nothing
Set objDoc = Nothing
Set objSel = Nothing
Set objCB = Nothing
Set objCBB = Nothing
End Sub