Differentiating attachments

[mdmackillop]

I'm putting code together to save attachments to a specific folder. When I run the code, it puts all attachments, including signature gif files and small jpgs which I don't want. The emails when received show only the "proper" attachment listed in the email heading. Is there a way other than file type to distinguish between the "proper" and incidental attachments?

[mvidas]

Hey Malcolm,

Good question. I know you can check the .type to see if its an OLE or embedded/etc. Checking the .class won't help. I just always save all the attachments then filter through them and delete in explorer :shrug:


Though you posted this 3 days ago, you probably already have your working code. Just in case you don't, heres the code I use:Option Explicit
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Sub SaveAllAttachmentsFromMessage()
Dim i As Long, tempStr As String, MailItm As Object, nFile As String
If ActiveInspector Is Nothing Then
Set MailItm = ActiveExplorer.Selection.Item(1)
Else
Set MailItm = ActiveInspector.CurrentItem
End If
If TypeName(MailItm) <> "MailItem" Then
MsgBox "This procedure only works on mail items"
Exit Sub
End If
tempStr = GetDirectory
If Len(tempStr) = 0 Then Exit Sub 'no directory specified
For i = 1 To MailItm.Attachments.Count
nFile = tempStr & MailItm.Attachments.Item(i).FileName
Do Until Len(Dir(nFile)) = 0
nFile = tempStr & CStr(Int(Rnd() * 30 + 1)) & MailItm.Attachments.Item(i).FileName
Loop
MailItm.Attachments.Item(i).SaveAsFile nFile
Next
End Sub

Sub SaveFilesFromMessage()
Dim i As Long, tempStr As String, MailItm As Object
If ActiveInspector Is Nothing Then
Set MailItm = ActiveExplorer.Selection.Item(1)
Else
Set MailItm = ActiveInspector.CurrentItem
End If
If TypeName(MailItm) <> "MailItem" Then
MsgBox "This procedure only works on mail items"
Exit Sub
End If
With MailItm.Attachments
For i = 1 To .Count
Select Case LCase(Mid(.Item(i).FileName, InStrRev(.Item(i).FileName, ".") + 1))
Case "gif", "jpg", "bmp" 'add any types you may want to save this way
tempStr = GetSaveAsFN(.Item(i).FileName)
If Len(tempStr) > 0 Then .Item(i).SaveAsFile tempStr
End Select
Next
End With
End Sub

Private Function GetSaveAsFN(ByVal vInitFile As String) As String
Dim OFN As OPENFILENAME, RetVal As Long, tStr As String, vExt As String
OFN.lStructSize = Len(OFN)
OFN.hwndOwner = 0
OFN.hInstance = 0
OFN.lpstrInitialDir = "C:\"
vInitFile = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace _
(vInitFile, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), """", ""), "<", ""), _
">", ""), "|", "")
vExt = Mid(vInitFile, InStrRev(vInitFile, ".") + 1)
If Len(vInitFile) > 250 - Len(OFN.lpstrInitialDir) Then
OFN.lpstrFile = Left(vInitFile, 250 - Len(OFN.lpstrInitialDir))
Else
OFN.lpstrFile = vInitFile & Space$(250 - Len(OFN.lpstrInitialDir) - Len(vInitFile))
End If
OFN.lpstrTitle = "Please Select File Location To Save This Message"
OFN.lpstrFilter = UCase(vExt) & " Files (*." & vExt & ")" & Chr(0) & "*." & vExt
OFN.nMaxFile = 255
OFN.lpstrFileTitle = Space$(254)
OFN.nMaxFileTitle = 255
OFN.flags = 0
RetVal = GetSaveFileName(OFN)
If RetVal Then
If InStr(1, OFN.lpstrFile, Chr(0)) > 0 Then
tStr = Left$(OFN.lpstrFile, InStr(1, OFN.lpstrFile, Chr(0)) - 1)
Else
tStr = OFN.lpstrFile
End If
GetSaveAsFN = tStr & IIf(LCase(Right(tStr, Len(vExt))) <> LCase(vExt), "." & vExt, "")
End If
End Function

Private Function GetDirectory() As String
Dim bInfo As BROWSEINFO, path As String, R As Long, X As Long, pos As Integer
bInfo.pidlRoot = 0&
bInfo.lpszTitle = "Select a folder to save all attachments to"
bInfo.ulFlags = &H51
X = SHBrowseForFolder(bInfo)
path = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal path)
If R Then
pos = InStr(path, Chr$(0))
path = Left$(path, pos - 1)
If Right(path, 1) <> "\" Then path = path & "\"
GetDirectory = path
End If
End FunctionMatt

[mdmackillop]

Thanks Matt,
I'll have a look through your code. I've never really programmed in Outlook so it's a learning experience. I did get something to workt I'll investigate type to see if that's the fix needed.