Outlook Attachment Types

[RonRepp]

Hi all:

I know OL isn't everyone's fave...mine either. I pieced together some nifty code (below) that takes the msgs from an OL2010 folder, saves it to the hard drive in whatever format the client wants, and then saves the attachments in a separate file.

From there, it logs all filenames in XL with hyperlinks to the files and msgs.

My problem is that during the attachment phase, it saves every .gif that might have been created for an RTF format of e-mail. It doesn't seem to do that in a text or HTML e-mail.

The only property I keep running in to is the class property, but when I debug, it just keeps giving me the same Type & Class of the object.

Any suggestions?

Private olNSpace As Outlook.NameSpace
Private MailInbox As Outlook.Folder
Private DestFolder As Outlook.Folder
Private MailItems As Outlook.Items
Private MailItm As Object
Private i As Integer
Private objFolder As Folder
Private strDate As String
Private strSub As String
Private winFldr As String
Private attFldr As String '= "\Attachments\"
Private eID As Long
Private StartPath As String
Private strSender As String
Private olFldrName As String
Private XL As Excel.Application

Private Sub ChooseFolder()


    Set olNSpace = Application.GetNamespace("MAPI")
    Set objFolder = olNSpace.PickFolder

    If TypeName(objFolder) <> "Nothing" Then
        
        LogFolder objFolder
    Else
        Debug.Print vbCr & "User pressed Cancel"
    End If

    Set objFolder = Nothing
    Set olNSpace = Nothing

End Sub

Private Sub LogFolder(ByVal olFolder As String)

Dim sFilePath As String
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim lngCount As Long
Dim j As Long
Dim attCount As Long

    ''Remove the hard coded path
    ''when you add a dialogue box to a form
    StartPath = "C:\EMails\"
    
    If Dir(StartPath) = "" Then
    
        sFilePath = CreateWinFolder(StartPath)
        
    End If
    
    
    Set olNSpace = Application.GetNamespace("MAPI")
    Set MailInbox = olNSpace.GetDefaultFolder(olFolderInbox)
    
    For i = 1 To MailInbox.Folders(olFolder).Items.Count
    
            If Dir(StartPath & olFolder & "\") = "" Then
            
                winFldr = CreateWinFolder(StartPath & olFolder & "\")
                attFldr = CreateWinFolder(winFldr & "\Attachments\")
                'Debug.Print winFldr & vbTab & attFldr
                
            End If
    
        eID = eID + 1
        

        Set DestFolder = MailInbox.Folders(olFolder)
        
        strSubject = ReplaceCharacters(DestFolder.Items(i), "-")
        strDate = GetStringDate(DestFolder.Items(i).SentOn)
        strSender = ReplaceCharacters(DestFolder.Items(i).SenderName, "-")
        
        
        ChDir winFldr
       
        If strSubject <> "" Then
        
            DestFolder.Items(i).SaveAs eID & " - " & Left(strSubject, 25) & ".rtf", olRTF
        Else
            DestFolder.Items(i).SaveAs eID & " - No Subject" & Left(strSubject, 25) & ".rtf", olRTF
        End If
        
        ''save attachments here
        ChDir attFldr
        SaveAttach DestFolder.Items(i), attFldr & "\"
        'Debug.Print DestFolder.Items(i), attFldr
        
    Next i
    
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set olNSpace = Nothing
Set MailInbox = Nothing
    
End Sub

Private Sub SaveAttach(ByVal objMailItem As Outlook.MailItem, ByVal strPath As String)

Dim objAtt As Outlook.Attachment
Dim SaveFolder As String
Dim attID As Long
Dim fso As Object
Dim strOldName
Dim strFileName As String
Dim strNewFileName As String
Dim attType As OlAttachmentType
Dim instance As Attachment
Dim value As OlObjectClass



SaveFolder = strPath
ChDir SaveFolder

Set fso = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next
    
    'If objMailItem.Attachments = 0 Then GoTo ReleaseObj
 [b]'Attachment section [/b]   
 For Each objAtt In objMailItem.Attachments
    attType = objAtt.Type
    value = objAtt.Class
    attID = attID + 1
    Debug.Print eID & " - " & attID & " -  attType - " & attType & " - value - " & value
    
    strFileName = SaveFolder & objAtt.DisplayName
    objAtt.SaveAsFile strFileName
 
    Set strOldName = fso.GetFile(strFileName)
    strNewFileName = eID & "-" & attID & "-" & objAtt.DisplayName
    strOldName.Name = strNewFileName

    Set objAtt = Nothing
[b]'to here [/b]
 Next
 
'Exit Sub

ReleaseObj:

''enter XL here
 Set objMailItem = Nothing
 Set fso = Nothing
  
  strFileName = ""
  strNewFileName = ""
  strOldName = ""
 
 End Sub

I have a few other questions, too, but one at a time.

Any help will be greatly appreciated.



Ron Repp

If gray hair is a sign of wisdom, then I'm a genius.

My newest novel: Wooden Warriors

http://www.repproductions.net