none
Need Help for Outlook VBA RRS feed

  • General discussion

  • I am using the below code , however this code is not extracting email within an email and attachment within that email

    Please advice what am i doing wrong here

    ' Setup and instructions
    ' (1) Digitally sign VBA project
    '          start->office->Microsoft office tools->digital certificates for VBA
    '          create a certificate
    ' (2) sign the code
    '          from Outlook -> menu -> Tools -> Macros -> Visual Basic Editor (VBA)
    '          project 1 -> Microsoft Office Outlook -> ThisOutlookSession (double ckick)
    '          * paste this source code *
    '          from Microsoft Visual Basic -> menu -> Tools -> digital signature -> (choose certificate previously created)
    ' (3) add icon on toolbar
    '          from outlook
    '          tools->customize (select "Commands" TAB)
    '                add icon on toolbar
    '                [rearrange commands] to change icon and name on toolbar
    ' (4) be sure that tools->macros->security
    '               on "thrusted publishers" "trust all installed add-ins and templates" is checked
    '
    '
     
    Private Declare Function SHGetFolderPath Lib "shell32.dll" Alias "SHGetFolderPathA" ( _
        ByVal HWnd As Long, ByVal csidl As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As Long
     
    Private Const MAX_PATH = 260&
     
    Public Sub StripAttachments()
        Dim ilocation As String
        Dim objOL As Outlook.Application
        Dim objMsg As Object
        Dim objAttachments As Outlook.Attachments
        Dim objSelection As Outlook.Selection
        Dim i As Long
        Dim lngCount As Long
        Dim strFile As String
        Dim strFolder As String
     
        Dim result
        
        'Put in the folder location you want to save attachments to
        ilocation = GetSpecialFolder(&H5) & "\Removed Attachs\" ' CSIDL_MY_DOCUMENTS As Long = &H5"
        On Error Resume Next
        
        result = MsgBox("Do you want to remove attachments from selected email(s)?", vbYesNo + vbQuestion)
        If result = vbNo Then
            Exit Sub
        End If
        
        ' Instantiate an Outlook Application object.
        ' Set objOL = CreateObject("Outlook.Application")
        Set objOL = Application
        ' Get the collection of selected objects.
        Set objSelection = objOL.ActiveExplorer.Selection
     
        ' Check each selected item for attachments.
        ' If attachments exist, save them to the Temp
        ' folder and strip them from the item.
        For Each objMsg In objSelection
            ' This code only strips attachments from mail items.
            If objMsg.Class = olMail Then
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.Count
                If lngCount > 0 Then
                    ' We need to use a count down loop for
                    ' removing items from a collection. Otherwise,
                    ' the loop counter gets confused and only every
                    ' other item is removed.
                    strFile = ""
                    For i = lngCount To 1 Step -1
                        ' Save attachment before deleting from item.
                        ' Get the file name.
                        
                        Dim strHTML As String
                        strHTML = "<li><a href=" & Chr(34) & "file:" & ilocation & objAttachments.Item(i).FileName & Chr(34) & ">" & objAttachments.Item(i).FileName & "</a><br>" & vbCrLf
                                            
                        strFile = strFile & strHTML
               
                        
                        ' Save the attachment as a file.
                        objAttachments.Item(i).SaveAsFile (ilocation & objAttachments.Item(i))
                        
                        ' Save the attachment as a file.
                        objAttachments.Item(i).Delete
                    Next i
                    
                    strFile = "Attachment removed from the message and backup-ed to[<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLf
                    
                    Dim objDoc As Object
                    Dim objInsp As Outlook.Inspector
                    Set objInsp = objMsg.GetInspector
                    Set objDoc = objInsp.WordEditor
                    
                    
                    objDoc.Characters(1).InsertBefore strFile
                    objMsg.HTMLBody = strFile + objMsg.HTMLBody
                    
                    Set objInsp = Nothing
                    Set objDoc = Nothing
                End If
                strFile = strFile & vbCrLf & vbCrLf
                objMsg.Save
            End If
        Next
     
    ExitSub:
        Set objAttachments = Nothing 
        Set objMsg = Nothing
        Set objSelection = Nothing
        Set objOL = Nothing
    End Sub
    Public Function GetSpecialFolder(FolderCSIDL As Long) As String
        Dim HWnd As Long
        Dim Path As String
        Dim Res As Long
        Dim ErrNumber As Long
        Dim ErrText As String
        Path = String$(MAX_PATH, vbNullChar)
        
        ''''''''''''''''''''''''''''''''''''''''''''
        ' get the folder name
        ''''''''''''''''''''''''''''''''''''''''''''
        Res = SHGetFolderPath(HWnd:=0&, _
                                csidl:=FolderCSIDL, _
                                hToken:=0&, _
                                dwFlags:=0&, _
                                pszPath:=Path)
        Select Case Res
            Case S_OK
                Path = TrimToNull(Text:=Path)
                GetSpecialFolder = Path
            Case S_FALSE
                MsgBox "The folder code is valid but the folder does not exist."
                GetSpecialFolder = vbNullString
            Case E_INVALIDARG
                MsgBox "The value of FolderCSIDL is not valid."
                GetSpecialFolder = vbNullString
            Case Else
                ErrNumber = Err.LastDllError
                ErrText = "ERROR!"
                MsgBox "An error occurred." & vbCrLf & _
                    "System Error: " & CStr(ErrNumber) & vbCrLf & _
                    "Description:  " & ErrText
        End Select
    End Function
    Public Function TrimToNull(Text As String) As String
        Dim N As Long
        N = InStr(1, Text, vbNullChar)
        If N Then
            TrimToNull = Left(Text, N - 1)
        Else
            TrimToNull = Text
        End If
    End Function

    Thursday, September 5, 2013 4:44 PM

All replies