I have a VBA script for Outlook. I am writing to download the attachments and sort them into their own folders. I am trying to call a function to calculate the name of the folder that it should go into based on the domain name but when I introduced the function, the rule is not running. I was able to download the files into a single folder when function was not there.
I have tried examples on changing function and also tried it as a Sub but unable to get them to work.
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim EmailAddress As String
Dim FullDomainName As String
Dim DomainName As String
Dim CalculatedFolderName As String
EmailAddress = itm.SenderEmailAddress
DomainName = ""
CalculatedFolderName = ""
If (InStr(EmailAddress, "#") > 0) Then
FullDomainName = Right(EmailAddress, Len(EmailAddress) - InStr(EmailAddress, "#"))
DomainName = Left(FullDomainName, InStr(FullDomainName, ".") - 1)
End If
MsgBox DomainName
CalculatedFolderName = FolderName(DomainName)
saveFolder = "c:\attachment\test\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & DomainName & " " & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub
Function FolderName(DomainName As String) As String
MsgBox DomainName
FolderName = ""
If (DomainName = "abc") Then FolderName = "A"
ElseIf (DomainName = "xyz") Then FolderName = "B"
Else
FolderName = DomainName
End If
Exit Function
End Function
I was expecting a folder name to return when the function is called.
The fix was done by moving the next statement to the next line.
If (DomainName = "abc") Then
FolderName = "A"
ElseIf (DomainName = "xyz") Then
FolderName = "B"
Related
I've an Outlook rule to run the following script when a specific email comes in.
I want the code to look in the specific folder, see if there is currently a file called CID.csv and if so delete it before saving the new CID.csv file into it.
Everything works except my line for saving the attachment.
The error I get is
Object variable or With block variable not set.
What do I set objAtt to?
Public Sub saveAttachtoDisk(item As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim strFileName As String
Dim STRFileExists As String
Dim strName As String
Dim EmAttFile As String
Dim i As Long
Dim EmAttachCount As Long
On Error GoTo ErrHandler
saveFolder = "\\page\data\NFInventory\groups\CID\Schedules\Nightly File Schedules\Deb's File Autosave\Extra Packs"
strFileName = "\\page\data\NFInventory\groups\CID\Schedules\Nightly File Schedules\Deb's File Autosave\Extra Packs\CID.csv"
STRFileExists = Dir(strFileName)
Set EmAttach = item.Attachments
AttachCount = EmAttach.Count
For i = AttachCount To 1 Step -1
' Get the file name
EmAttFile = EmAttach.item(i).FileName
If EmAttFile = "CID.csv" Then
If STRFileExists = "" Then
'MsgBox "The selected file doesn't exist"
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Else
MsgBox "The selected file exists"
Kill "S:\NFInventory\groups\CID\Schedules\Nightly File Schedules\Deb's File Autosave\Extra Packs\CID.csv"
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
End If
End If
Next i
ErrHandler:
If Err.Number <> 0 Then
MsgBox "Error Number:" & Err.Number & vbCrLf & _
"Error Description: " & Err.Description
Exit Sub
Else
End If
End Sub
While not an answer per se, you may find a generic save attachment function useful:
With it you can use or set a number of different options (such as only saving the ".pdf,.txt" files, or deleting any saved attachments or overwriting existing files)
NB: you should actually be able to use FileExtensions:="\CID.csv" to save a specific file
Private Function SaveAttachments(ByVal Item As Object, FilePath As String, _
Optional Prefix As String = "", _
Optional FileExtensions As String = "*", _
Optional Delimiter As String = ",", _
Optional RemoveAttachments As Boolean = False, _
Optional OverwriteFiles As Boolean = False) As Boolean
On Error GoTo ExitFunction
Dim i As Long, j As Long, FileName As String, Flag As Boolean
Dim Extensions() As String: Extensions = Split(FileExtensions, Delimiter)
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
For j = LBound(Extensions) To UBound(Extensions)
With Item.Attachments
If .Count > 0 Then
For i = .Count To 1 Step -1
FileName = FilePath & Prefix & .Item(i).FileName
Flag = IIf(LCase(Right(FileName, Len(Extensions(j)))) = LCase(Extensions(j)), True, False)
Flag = IIf(FileExtensions = "*" Or Flag = True, True, False)
If Flag = True Then
If Dir(FileName) = "" Or OverwriteFiles = True Then
.Item(i).SaveAsFile FileName
Else
Debug.Print FileName & " already exists"
Flag = False
End If
End If
If RemoveAttachments = True And Dir(FileName) <> "" And Flag = True Then .Item(i).Delete
Next i
End If
End With
Next j
SaveAttachments = True
ExitFunction:
End Function
You should define objAtt before to use it:
...
For i = AttachCount To 1 Step -1
EmAttFile = EmAttach.item(i).FileName
If EmAttFile = "CID.csv" Then
objAtt = EmAttach.item(i) ' <---- Define objAtt before to use it
If STRFileExists = "" Then
'MsgBox "The selected file doesn't exist"
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Else
MsgBox "The selected file exists"
Kill "S:\NFInventory\groups\CID\Schedules\Nightly File Schedules\Deb's File Autosave\Extra Packs\CID.csv"
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
End If
End If
Next i
...
I would like to get the value (The regex result) of the function below inside my main sub in orde to add it to the title of my file, how can I do this ?
Public Sub Process_SAU(Item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
Dim Code as String
Code = ExtractText
' Folder location when I want to save my file
saveFolder = "C:\Users\gdeange1\Desktop\suggestion updates\UpdateBusinessInformation\Processed_By_Bulks"
For Each object_attachment In Item.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".json") Then
object_attachment.SaveAsFile saveFolder & "\" & Format(Now(), "dd-mm-yyyy") & "_" & Code & "_" & object_attachment.DisplayName
End If
Next
End Sub
Function ExtractText(Str As String) ' As String
Dim regEx As New RegExp
Dim NumMatches As MatchCollection
Dim M As Match
regEx.Pattern = "((.*))[A-Z]{0}(Danièle Loubert|Véronique Mantha|Julie-Emmanuelle Carle|Nicolas Bertrand|Martine Jean)"
Set NumMatches = regEx.Execute(Str)
If NumMatches.Count = 0 Then
ExtractText = "Blabla"
Else
Set M = NumMatches(0)
ExtractText = M.SubMatches(0)
End If
Code = ExtractText
End Function
The code I tried above did not work.
Thank's for your help!
You might have copied the function ExtractText(Str As String) , but this function expects a string value to be passed while using this function, which you are missing. If you pass a string type value while using the function in your main code, it should work.
You pass Item to Public Sub Process_SAU(Item As MailItem).
Similarly, you have to pass Str to Function ExtractText(Str As String) As String.
Option Explicit
Private Sub test_Process_SAU()
Dim currItem As Object
' with a selected item
Set currItem = ActiveExplorer.Selection(1)
' or
' with an open item
'Set currItem = ActiveInspector.currentItem
If currItem.Class = olMail Then
Process_SAU currItem
End If
End Sub
Public Sub Process_SAU(Item As MailItem)
Dim Code As String
' Pass the applicable string to the function
Code = ExtractText(Item.body)
Debug.Print " Code: " & Code
Dim object_attachment As outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Users\gdeange1\Desktop\suggestion updates\UpdateBusinessInformation\Processed_By_Bulks"
For Each object_attachment In Item.Attachments
If InStr(object_attachment.DisplayName, ".json") Then
object_attachment.SaveAsFile saveFolder & "\" & Format(Now(), "dd-mm-yyyy") & "_" & Code & "_" & object_attachment.DisplayName
End If
Next
End Sub
Function ExtractText(Str As String) As String
Dim regEx As New regExp
Dim NumMatches As MatchCollection
Dim M As Match
regEx.Pattern = "((.*))[A-Z]{0}(Danièle Loubert|Véronique Mantha|Julie-Emmanuelle Carle|Nicolas Bertrand|Martine Jean)"
Set NumMatches = regEx.Execute(Str)
If NumMatches.count = 0 Then
ExtractText = "Blabla"
Else
Set M = NumMatches(0)
ExtractText = M.Value
End If
End Function
I have emails with pdf attachments I would like to save automatically as they come into my inbox. I have my code mostly written, I have tested that all the variables have the correct value, and they output the correct data; however, I'm not sure how to code the actual saving of the file.
The file will get renamed to the customer's address, which is extracted with my code below:
Sub EagleViewSaveAttachment()
'Define Variables
Dim sFileName As String
Dim varAddress As Variant
Dim City As Variant
Dim fdObj As Object
Dim NextFriday As Date
Dim JobArea As String
Dim JobCity As Variant
Dim myPath As String
Dim objAtt As Outlook.Attachment
Dim myFinalPath As String
'Set Variables
NextFriday = Date + 8 - Weekday(Date, vbFriday)
myPath = "C:\Users\admin\OneDrive\Documents\EagleView\"
Set myfolder = Outlook.ActiveExplorer.CurrentFolder
Set fdObj = CreateObject("Scripting.FileSystemObject")
'Loop through emails in folder
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
'Search for Specific Text
delimitedMessage = Replace(msgtext, "Address: ", "###")
delimitedMessage = Replace(delimitedMessage, ",", "###")
varAddress = Split(delimitedMessage, "###")
'Assign the job address from email to variable
sFileName = varAddress(10)
JobCity = LTrim(varAddress(11))
'Define office area based on job city
If JobCity = "Panama City" Or JobCity = "Mexico Beach" Or JobCity = "Panama City Beach" Or JobCity = "Lynn Haven" Or JobCity = "Port Saint Joe" Then
JobArea = "Panama"
ElseIf JobCity = "Daytona Beach" Or JobCity = "Port Orange" Or JobCity = "Deltona" Or JobCity = "Ormond Beach" Or JobCity = "Deland" Then
JobArea = "Daytona"
ElseIf JobCity = "Orlando" Then
JobArea = "Orlando"
ElseIf JobCity = "Jacksonville" Then
JobAre = "Jacksonville"
Else
JobArea = LTrim(varAddress(11))
End If
'Define Final Path
myFinalPath = myPath + Format$(NextFriday, "yyyy-mm-dd") + "\" + JobArea + "\"
'Check if the path exists, if not create it
If fdObj.FolderExists(myFinalPath) Then
MsgBox "Found it."
Else
fdObj.CreateFolder (myFinalPath)
MsgBox "It has been created."
End If
Next
End Sub
As of right now, what I am unable to do is get it to check if the directory C:\Users\admin\OneDrive\Documents\EagleView\yyyy-mm-dd\JobArea already exists and to create it if it doesn't already exist.
I'm fairly certain the problem lies in my usage of fdObj.FolderExists(myFinalPath) as it seems that doesn't accept variables.
Use function like this
Private Function CreateDir(FldrPath As String)
Dim Elm As Variant
Dim CheckPath As String
CheckPath = ""
For Each Elm In Split(FldrPath, "\")
CheckPath = CheckPath & Elm & "\"
If Len(Dir(CheckPath, vbDirectory)) = 0 Then
MkDir CheckPath
Debug.Print CheckPath & " Folder Created"
End If
Debug.Print CheckPath & " Folder Exist"
Next
End Function
then call it
Example
'Define Final Path
myFinalPath = myPath + Format$(NextFriday, "yyyy-mm-dd") + "\" + JobArea + "\"
CreateDir myFinalPath ' <--- call call function
According to my search, fdObj.FolderExists() can accept variables, like this:
Sub Test_File_Exist_FSO_Early_binding()
'If you want to use the Intellisense help showing you the properties
'and methods of the objects as you type you can use Early binding.
'Add a reference to "Microsoft Scripting Runtime" in the VBA editor
'(Tools>References)if you want that.
Dim FSO As Scripting.FileSystemObject
Dim FilePath As String
Set FSO = New Scripting.FileSystemObject
FilePath = "C:\Users\Ron\test\book1.xlsm"
If FSO.FileExists(FilePath) = False Then
MsgBox "File doesn't exist"
Else
MsgBox "File exist"
End If
End Sub
Reference from:
Test if Folder, File or Sheet exists or File is open
You could save and rename attachment refer to the below link:
Save attachments to a folder and rename them
Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
This question does not appear to be about a specific programming problem, a software algorithm, or software tools primarily used by programmers. If you believe the question would be on-topic on another Stack Exchange site, you can leave a comment to explain where the question may be able to be answered.
Closed 7 years ago.
Improve this question
I am curious to know how to move emails from a specific subfolder to my hard drive. Basically, my inbox has about 20 subfolders. I want to be able to move all the emails from subfolder1 to my hard drive.
Is there a macro to specifically go to that folder and move all the emails onto my hard drive? Granted I do want to keep all the emails in .msg rather than being a .txt file.
I bielive you can develop a VBA macro or add-in to get the job done. See Getting Started with VBA in Outlook 2010 to get started.
The SaveAs method of the MailItem class saves the Microsoft Outlook item to the specified path and in the format of the specified file type. If the file type is not specified, the MSG format (.msg) is used. The file type to save can be one of the following OlSaveAsType constants: olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode. For example:
Sub SaveAsMSG()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? " & _
"If a file with the same name already exists, " & _
"it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
This should allow you to select outlook folder and hard drive folder, All emails in that folder and all sub folders will be saved to your HD
Option Explicit
Sub SaveMsgToFolders()
Dim i, j, n As Long
Dim sSubject As String
Dim sName As String
Dim sFile As String
Dim sReceived As String
Dim sPath As String
Dim sFolder As String
Dim sFolderPath As String
Dim SaveFolder As String
Dim Prompt As String
Dim Title As String
Dim iNameSpace As NameSpace
Dim olApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim olmItem As MailItem
Dim FSO, ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Set FSO = CreateObject("Scripting.FileSystemObject")
Set olApp = Outlook.Application
Set iNameSpace = olApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder ' // Chose Outlook Folder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"
sPath = BrowseForFolder
If sPath = "" Then
GoTo ExitSub:
End If
If Not Right(sPath, 1) = "\" Then
sPath = sPath & "\"
End If
Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
For i = 1 To Folders.Count
sFolder = StripIllegalChar(Folders(i))
n = InStr(3, sFolder, "\") + 1
sFolder = Mid(sFolder, n, 256)
sFolderPath = sPath & sFolder & "\"
SaveFolder = Left(sFolderPath, Len(sFolderPath) - 1) & "\"
If Not FSO.FolderExists(sFolderPath) Then
FSO.CreateFolder (sFolderPath)
End If
Set SubFolder = olApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
On Error Resume Next
For j = 1 To SubFolder.Items.Count
Set olmItem = SubFolder.Items(j)
sReceived = ArrangedDate(olmItem.ReceivedTime)
sSubject = olmItem.Subject
sName = StripIllegalChar(sSubject)
sFile = SaveFolder & sReceived & "_" & sName & ".msg"
sFile = Left(sFile, 256)
olmItem.SaveAs sFile, 3
Next j
On Error GoTo 0
Next i
ExitSub:
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "")
ExitFunction:
Set RegX = Nothing
End Function
Function ArrangedDate(sDateInput)
Dim sFullDate As String
Dim sFullTime As String
Dim sAMPM As String
Dim sTime As String
Dim sYear As String
Dim sMonthDay As String
Dim sMonth As String
Dim sDay As String
Dim sDate As String
Dim sDateTime As String
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
If Not Left(sDateInput, 2) = "10" And _
Not Left(sDateInput, 2) = "11" And _
Not Left(sDateInput, 2) = "12" Then
sDateInput = "0" & sDateInput
End If
sFullDate = Left(sDateInput, 10)
If Right(sFullDate, 1) = " " Then
sFullDate = Left(sDateInput, 9)
End If
sFullTime = Replace(sDateInput, sFullDate & " ", "")
If Len(sFullTime) = 10 Then
sFullTime = "0" & sFullTime
End If
sAMPM = Right(sFullTime, 2)
sTime = sAMPM & "-" & Left(sFullTime, 8)
sYear = Right(sFullDate, 4)
sMonthDay = Replace(sFullDate, "/" & sYear, "")
sMonth = Left(sMonthDay, 2)
sDay = Right(sMonthDay, Len(sMonthDay) - 3)
If Len(sDay) = 1 Then
sDay = "0" & sDay
End If
sDate = sYear & "-" & sMonth & "-" & sDay
sDateTime = sDate & "_" & sTime
RegX.Pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(sDateTime, "-")
ExitFunction:
Set RegX = Nothing
End Function
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, Fld As MAPIFolder)
Dim SubFolder As MAPIFolder
Folders.Add Fld.FolderPath
EntryID.Add Fld.EntryID
StoreID.Add Fld.StoreID
For Each SubFolder In Fld.Folders
GetFolder Folders, EntryID, StoreID, SubFolder
Next SubFolder
ExitSub:
Set SubFolder = Nothing
End Sub
Function BrowseForFolder(Optional OpenAt As String) As String
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then
BrowseForFolder = ""
End If
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then
BrowseForFolder = ""
End If
Case Else
BrowseForFolder = ""
End Select
ExitFunction:
Set ShellApp = Nothing
End Function
How can I programmatically create multiple levels of subfolders in VBA for MS Access? I know that MKDir only allows me to create one level, but I want to create 2 levels. The first level folder is based on the year the shipment took place, then the sub-level folder to that is the shipment number. The idea is to check and see if a folder(s) exists, and if not to create and open them.
Here is what I have so far:
Private Sub Command173_Click()
Const strParent = "S:\shipments\"
Dim strYearEntered As String
Dim strEntryNumber As String
Dim strFolder As String
Dim fso As Object
strYearEntered = Me.YearEntered
strEntryNumber = Me.EntryNum
strFolder = strParent & strYearEntered & "\" & strEntryNumber
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FOLDEREXISTS(strFolder) = False Then
fso.CreateFolder strFolder
End If
Shell "explorer.exe " & strFolder, vbNormalFocus
End Sub
Using this code gives me an error at the "fso.CreateFolder strFolder" line. This problem only occurred when I placed the "\" in the strFolder line, without the "\" it will only create one folder by cramming together the YearEntered and EntryNum values. Can anyone assist in this matter?
Thanks.
Private Sub Command173_Click()
Const strParent = "S:\shipments\"
Dim strYearEntered As String
Dim strEntryNumber As String
Dim strFolder As String
strYearEntered = Me.YearEntered
strEntryNumber = Me.EntryNum
strFolder = strParent & strYearEntered
If Dir(strFolder, vbDirectory) = "" then MkDir strFolder
strFolder = strFolder & "\" & strEntryNumber
If Dir(strFolder, vbDirectory) = "" then MkDir strFolder
Shell "explorer.exe " & strFolder, vbNormalFocus
End Sub
Edit:
As a recommendation of Still Learning I'm adding this article as a reference: Create Nested Directories
This answer maybe is too late but I will like to share with you this VBA util function where you can create subfolders recursive (multi-level) in a path.
Function createDirIfNotFound(ByVal sPath As String)
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
If sPath <> "" Then
aDirs = Split(sPath, "\")
If Left(sPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
mkDir sCurDir
End If
Next i
End If
End Function
And you can use it like this, and folders will be created deeply if not found:
createDirIfNotFound "c:\root\level1\level2"
I hope this helps somebody.