Macro doesn't recognize local mails from colleagues

[kko]

Hi,

I copied a save all attachment vba script and was able to modify the script to do what I want. However, because we are using an exchange server... this script is unable to grab the attachments my colleague send me - only external emails. Can anyone please help?

Thanks

Public Sub Save_Attach_To_Disk(itm As Outlook.MailItem)

If (itm.Attachments.Count >= 1) Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim objAtt As Outlook.Attachment

Dim dateFormat_file_name
dateFormat_file_name = Format(itm.ReceivedTime, "yyyy-mm-dd H-mm ")

Dim dateFormat_target_folder
dateFormat_target_folder = Format(itm.ReceivedTime, "yyyy-mm-dd")

Dim StrDomainName
StrDomainName = Right(itm.SenderEmailAddress, Len(itm.SenderEmailAddress) - InStr(1, itm.SenderEmailAddress, "@"))

''''''''''''''''''''''''''''''''''''''''''''
Dim Supplier_Folder As String
Supplier_Folder = "Z:\By Supplier" ' you can change the folder

Dim Date_Folder As String
Date_Folder = "Z:\By Date" ' you can change the folder
''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''
Dim saveFolder_Root2 As String
saveFolder_Root2 = Supplier_Folder & "\" & StrDomainName

Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(saveFolder_Root2) Then
objFSO.CreateFolder (saveFolder_Root2)
End If
''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''
Dim saveFolder_ByDate As String
saveFolder_ByDate = Date_Folder & "\" & dateFormat_target_folder
If Not objFSO.FolderExists(saveFolder_ByDate) Then
objFSO.CreateFolder (saveFolder_ByDate)
End If
''''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''
For Each objAtt In itm.Attachments
If (InStr(objAtt.DisplayName, ".PDF") Or InStr(objAtt.DisplayName, ".html") Or InStr(objAtt.DisplayName, ".msg") Or InStr(objAtt.DisplayName, ".htm")) Then
objAtt.SaveAsFile saveFolder_Root2 & "\" & dateFormat_file_name & " - " & objAtt.DisplayName
objAtt.SaveAsFile saveFolder_ByDate & "\" & dateFormat_file_name & " By " & StrDomainName & " - " & objAtt.DisplayName
End If
Set objAtt = Nothing
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
End Sub

 

[Michael Bauer]

Did you check if the script is called at all for internal senders? If so, I guess the issue is due to strDomainName being invalid. The SenderEmailAddress doesn't have a @ for internal addresses, so strDomainName will hold the entire address, which could be too long, or have characters that aren't allowed for file names.

See the last procedure here, which replaces those invalid characters. Call it for instance

ReplaceCharsForFileName strDomainName, "_"

in order to replace each invalid char by a "_".

 

[Diane Poremsky]

In rules, i use /ou to look for internal email - you can either check for /ou or @ using an if statement
if instr(1,senderemailaddress, "@") > 1 then
' use the strdomain code you use now
else
strdomainname = "work"
end if

If you want to file by alias, grabbing the user's alias can be as simple as finding the last /cn= and taking what is to the right but if you use Office365 (and possibly on newer on premise setups), it adds a guid before the alias you need the last hyphen and hope the person's alias does not use a hyphen.

This is from an Office 365 account:
/O=EXCHANGELABS/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN=43DFB970E3B54F85942D1348B58581E6-MARYC

This will get the addresses so you can see if it uses the alias or the guid-alias format

Public Sub Getx500Address()
    Dim objMail As Object
    Set objMail = Application.ActiveExplorer.Selection.Item(1)
    
     MsgBox objMail.SenderEmailAddress
 
Set objMail = Nothing
End Sub