Save attachment with subject name - excel

I am trying to save attachments from all e-mails in a certain folder. This is a daily process so it also deletes downloaded attachments.
The names of the files are not constant and I need them to have the same name after saving as subject name from e-mail they came from.
Every e-mail contains one attachment. Is it possible to modify current code so it saves with subject name instead of attachment name?
Sub Spremanje()
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Mapa za spremanje izvještaja", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
' Ask the user to select an Outlook folder to process
Dim olPurgeFolder As Outlook.MAPIFolder
Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
If olPurgeFolder Is Nothing Then Exit Sub
' Iteration variables
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim sSavePathFS As String
Dim sDelAtts
For Each msg In olPurgeFolder.Items
sDelAtts = ""
' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
' on our olPurgeFolder.Items collection. The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment. Each update will
' reindex the collection. As a result, it does not provide a reliable means for iteration.
' This is why the For Each loops will not work.
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method
' which will decrement msg.Attachments.Count by one each time.
While msg.Attachments.Count > 0
' Save the file
sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Subject(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior.
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg. If you forget this line, the attachments will not be deleted.
msg.Save
End If
Next
End Sub

In the code the path is set in the following way:
' Save the file
sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Subject(1).FileName
To use a subject you can use the Subject property in the code:
sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Subject & " - " & msg.Attachments(1).FileName
But you need to create a unique filename for the attached file, so it makes sense to introduce some kind of ID for the attached files. It can be a date string when the item was received (ReceivedTime) or any other identifier which could uniquely related to a particular attachments.
Also I'd suggest replacing the while loop in the code, so that you could the the currently iterated mail item in the code without maintaining another indexes:
' This While loop is controlled via the .Delete method
' which will decrement msg.Attachments.Count by one each time.
While msg.Attachments.Count > 0
Instead, you could use reverse for loop in the code.
For i = msg.Attachments.Count To 1 Step -1
So, you may get the item easily:
Set att = msg.Attachments.Item(i)

Related

Get Emails Not Replied from Shared mailbox VBA

I am trying to Extract Emails from Shared mailbox which i am not Owner i have access to send on behalf
but Unable to save search and If any one can assist to Get Email in last 24hours Which are not Replied from Shared Mailbox
Below is Code Which I was Able to do it
Sub CreateSearchFolder_AllNotRepliedEmails()
Dim OutlookApp As Outlook.Application
Dim strScope As String
Dim OutlookNamespace As NameSpace
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Outlook.Search
Dim objOwner As Outlook.Recipient
Dim Folder As MAPIFolder
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objOwner = OutlookNamespace.CreateRecipient("Sdk#dau.ae")
objOwner.Resolve
Set objOwner = OutlookNamespace.CreateRecipient("Sdk#dau.ae")
objOwner.Resolve
'If objOwner.Resolved Then
'Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & Application.Session.GetSharedDefaultFolder(objOwner, olFolderInbox).FolderPath & "'"
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & "AND" & Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Set objSearch = Outlook.Application.AdvancedSearch(Scope:=strScope, Filter:=strFilter, SearchSubFolders:=True)
'Save the search folder
objSearch.Save ("Sd email not Replied")// Tried This But Not working
MsgBox "Search folder is created successfully!", vbInformation + vbOKOnly, "Search Folder"
End Sub
Kindly advise for Solution
There is no reason to use (asynchronous) AdvancedSearch (unless you want the list saved as a search folder); use (synchronous) Items.Restrict:
filter = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
set folder = Application.Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
set notRepliedOrForwardedItems = folder.Items.Restrict(filter)
This demonstrates processing search results without a search folder.
After a Eureka moment.
Option Explicit
' Code in ThisOutlookSession
Public blnSearchComp As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal objSearch As Search)
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch
' Code should be in a class module such as ThisOutlookSession
Debug.Print "The AdvancedSearchComplete Event fired"
If objSearch.Tag = "AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701" Then
'm_SearchComplete = True` ' Use Option Explicit.
blnSearchComp = True
End If
End Sub
Private Sub AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701()
' Code in ThisOutlookSession
Dim strScope As String
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Search
Dim objOwner As Recipient
Dim rsts As results
Dim objFolder As Folder
' For testing
Set objFolder = Session.GetDefaultFolder(olFolderInbox)
'Set objOwner = Session.CreateRecipient("Sdk#dau.ae")
'objOwner.Resolve
'If objOwner.Resolved Then
' Set objFolder = Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & objFolder.folderPath & "'"
Debug.Print "strScope : " & strScope
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & _
"AND" & Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Debug.Print "strFilter : " & strFilter
' Fewer results than above.
'strFilter = """http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
'Debug.Print "strFilter : " & strFilter
' If subfolders not required then Restrict on single folder would be simpler.
'
' If subfolder search required "SearchSubFolders:=True" then
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strFilter, SearchSubFolders:=True, _
Tag:="AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder_220701")
' 2022-07-01 Eureka!
blnSearchComp = False
' Otherwise remains True.
' Search would work once until Outlook restarted.
While blnSearchComp = False
DoEvents
'Code should be in a class module such as ThisOutlookSession
Debug.Print "Wait a few seconds. Ctrl + Break if needed."
Wend
Debug.Print "objSearch.results.count: " & objSearch.results.count
Set rsts = objSearch.results
' When no saved searchfolder, ensure the search is complete before processing the results.
'
' ---> The Application.AdvancedSearchComplete event signals when search is complete. <---
'
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
' Errors in the sample code:
' Typo blnSearchComp = True - use Option Explicit
' Syntax error Set sch = Application.AdvancedSearch(strS, strF, , "Test") - Missing comma
' Before each search: blnSearchComp = False - Else permanently True after first run
'
' ********************************************
' *** Process search result without saving ***
' ********************************************
If rsts.count > 0 Then
Debug.Print "rsts.count: " & rsts.count
rsts.Sort "[ReceivedTime]", True
With rsts(1)
Debug.Print "First item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
With rsts(rsts.count)
Debug.Print " Last item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
Else
Debug.Print "No items found."
End If
Debug.Print "Done."
End Sub
Leaving this in case there are even more pitfalls in AdvancedSearch.
Option Explicit
Private Sub AdvancedSearch_WithSubfolders_AllNotRepliedEmails_WithoutSavingSearchFolder()
' Code in Outlook
Dim strScope As String
Dim strRepliedProperty As String
Dim strFilter As String
Dim objSearch As Search
Dim objOwner As Recipient
Dim rsts As results
Dim objFolder As Folder
' For testing
Set objFolder = Session.GetDefaultFolder(olFolderInbox)
'Set objOwner = Session.CreateRecipient("Sdk#dau.ae")
'objOwner.Resolve
'If objOwner.Resolved Then
' Set objFolder = Session.GetSharedDefaultFolder(objOwner, olFolderInbox)
'End If
strScope = "'" & objFolder.folderPath & "'"
Debug.Print "strScope : " & strScope
'Search filter
strRepliedProperty = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strFilter = Chr(34) & strRepliedProperty & Chr(34) & " <> 102" & "AND" _
& Chr(34) & strRepliedProperty & Chr(34) & " <> 103"
Debug.Print "strFilter : " & strFilter
' Deleted question indicates other options
' https://stackoverflow.com/questions/19381504/determine-whether-mail-has-been-replied-to
' 102 "Reply to Sender"
' 103 "Reply to All"
' 104 "Forward"
' 108 "Reply to Forward"
' Fewer results than above. NULL may be correct.
'strFilter = """http://schemas.microsoft.com/mapi/proptag/0x10810003"" IS NULL"
'Debug.Print "strFilter : " & strFilter
' If subfolders not required then Restrict on single folder would be simpler.
'
' If subfolder search required "SearchSubFolders:=True" then
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strFilter, SearchSubFolders:=True)
Set rsts = objSearch.results
' When no saved searchfolder, ensure the search is complete before processing the results.
'
' ---> The Application.AdvancedSearchComplete event signals when search is complete. <---
'
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
' https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba
'
' I have to use a workaround for AdvancedSearchComplete.
' I delay to allow the search to complete.
' Resist using this workaround in production code.
'Debug.Print "rsts.count: " & rsts.count
If rsts.count = 0 Then
Dim waitTime As Long
Dim delay As Date
moreDelay:
Debug.Print " Delay invoked."
waitTime = 1 ' in seconds - adjust as needed
Debug.Print vbCr & "Wait start: " & Now
delay = DateAdd("s", waitTime, Now)
Debug.Print "Wait until: " & delay
Do Until Now > delay
DoEvents
Loop
'Debug.Print "rsts.Count: " & rsts.count
If rsts.count = 0 Then
Debug.Print "No mail found or delay too short."
If MsgBox("No mail found or delay too short. Allow more time?", vbYesNo) = vbYes Then
GoTo moreDelay
Else
Debug.Print "No items found. / Search failure acknowledged."
End If
Else
Debug.Print " Delay successful."
GoTo processItems
End If
Else
Debug.Print "Delay not required."
GoTo processItems
End If
Debug.Print "Done."
Exit Sub
processItems:
' ---> After search is confirmed complete with AdvancedSearchComplete <---
' ********************************************
' *** Process search result without saving ***
' ********************************************
If rsts.count > 0 Then
Debug.Print "rsts.count: " & rsts.count
rsts.Sort "[ReceivedTime]", True
With rsts(1)
Debug.Print "First item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
With rsts(rsts.count)
Debug.Print " Last item in results: " & .ReceivedTime & " " & .subject
' .Display ' If required
End With
End If
Debug.Print "Done."
End Sub

Merging PDF's using Excel 2016 VBA with Adobe Acrobat DC

I have an Excel 2016 macro that merges or connects PDF documents together using Adobe Acrobat X. I no longer have Acrobat X, it was replaced with Adobe Acrobat DC. Due to this, I get an error message that Excel is waiting for another application to complete an action that just continues to prompt. The line this happens on is:
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
I assume I need a different way to open or create a PDF document using a Acrobat DC method, but am unsure what that would be. Can anyone assist me on the differences with moving to using the DC version? I tried to locate information but was unable to see a DC version of opening/creating a PDF.
Thank you for any assistance!!!
Sub MergePDFs(MyFiles As String, DestFile As String, DestPath As String)
' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
' Reference required: "VBE - Tools - References - Acrobat"
Dim a As Variant
Dim i As Long
Dim n As Long
Dim ni As Long
Dim p As String
Dim AcroApp As New Acrobat.AcroApp
Dim PartDocs() As Acrobat.CAcroPDDoc
p = Environ("temp") & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, DestPath & DestFile & ".PDF") Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
'MsgBox "The resulting file is created:" & vbLf & DestPath & DestFile & ".PDF", vbInformation, "Done"
strErrorMessage = strErrorMessage & "The resulting file is created:" & vbLf & DestPath & DestFile & ".PDF" & Chr(13) & Chr(13)
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub

Creating a self install macro?

Hello I create many macros for my co workers. The current method I have for distributing to another computer is going into the vba editor and importing.
I would really like to make a kind of "installer" for macros that would allow the user to install a new macro without having to go into the editor. I'm not sure this is even possible but any ideas are welcome!
Thanks!
You need to enable Microsoft Scripting Runtime library under references. (VBE -> Tools -> References. Check the box.)
Basically, you create a string that holds the code of the macro you want to install. Obviously, the string could be really long with many lines of code so you might need several string variables.
Dim toF As Workbook
Dim codeMod As CodeModule
Dim code As String
Dim fso As Scripting.FileSystemObject
Dim folder As folder
Dim name As String, file As String
Application.ScreenUpdating = False
Set fso = New FileSystemObject
Set folder = fso.GetFolder("C:\folder\here")
name = nameOfFileHere
file = folder & "\" & name
Set toF = Workbooks.Open(file)
'modify ThisWorkbook to place it elsewhere
Set codeMod = toF.VBProject.VBComponents("ThisWorkbook").CodeModule
'erase everything if code already exists
If codeMod.CountOfLines > 0 Then
codeMod.DeleteLines 1, codeMod.CountOfLines
End If
'dump in new code
code = _
"Private Sub Workbook_Open()" & vbNewLine & _
" Dim user as String" & vbNewLine & _
" Dim target as String" & vbNewLine & _
" user = Application.UserName" & vbNewLine & _
" target = """ & findUser & """" & vbNewLine & _
" If user = target then" & vbNewLine & _
" MsgBox ""I just dumped in some code.""" & vbNewLine & _
" End if" & vbNewLine & _
"End Sub" & vbNewLine
With codeMod
.InsertLines .CountOfLines + 1, code
End With
Application.ScreenUpdating = True

vba if cell contains value which matches file name then say ok else say not ok?

I have updated my code to explain a bit more about what it is im trying to do...
i am generating a random string with numbers and letters and creating a text file with the name of the random generated string, in this case im calling my string: strPassword
Now once the text file is created i want to perform a check to see if this file name exists.
So this means retrieving the random string which was created and saved as the file name.
If the file exists i should get a message saying ok otherwise it should say not ok.
I am trying to retrieve the file name by calling strPassword
For some reason its telling me the file does not exist so I can only assume its having trouble getting the value of strPassword. it appears once a random number has been generated it forgets what was generated, so is there a way I can save strPassword to a variable or session or some kind of memory to perform a check for the filename later?
When my cell A1 is clicked it performs a check to see if the filename exists in cell S32, if it doesn't exists a message is show and the file is created with the random string strPassword and saved.
Then If I want to type this string name into cell S32 it should say file exists because it has just created it, but its not its saying file does not exist.
For instance if I have a text file that's filename was randomly generated by usiung strPassword located at:
P:\XBQILGHD.txt
So in my cell in excel if I was to type:
XBQILGHD (which is the strPassword value)
then I would get a message that says 'OK' otherwise I would get a message that says 'NOT OK'
can someone please show me what I am doing wrong here?
thanks
Dim strPassword As String
Dim i As Integer
For i = 1 To 10
If i Mod 2 = 0 Then
strPassword = Chr(Int((90 - 65 + 1) * Rnd + 65)) & strPassword
Else
strPassword = Int((9 * Rnd) + 1) & strPassword
End If
Next i
If Dir("P:\" & strPassword & ".txt") <> "" Then
MsgBox "File exists"
Else
MSG3 = MsgBox("Hi " & Range("N9").Value & "," & vbNewLine & vbNewLine & "Unfortunately you have used up your entire allowance for this month." & vbNewLine & vbNewLine & "You will not be able to continue with this request. Please wait until next month, when your request allowance will be reset." & vbNewLine & vbNewLine & "Think this is an Error?" & vbNewLine & "Contac us at NewSuppliers#Hewden.co.uk to make an appeal.", vbOKOnly, "Important Notice!")
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("P:\" & strPassword & ".txt", True)
a.WriteLine (strPassword)
a.Close
End If
If i understand your problem try it: in file ttp.txt was saved your pwd
Dim strPassword As String
Dim i As Integer
For i = 1 To 10
If i Mod 2 = 0 Then
strPassword = Chr(Int((90 - 65 + 1) * Rnd + 65)) & strPassword
Else
strPassword = Int((9 * Rnd) + 1) & strPassword
End If
Next i
If Dir("P:\ttp.txt") <> "" Then
MsgBox "File exists"
Else
MSG3 = MsgBox("Hi " & Range("N9").Value & "," & vbNewLine & vbNewLine & "Unfortunately you have used up your `enter code here`entire allowance for this month." & vbNewLine & vbNewLine & "You will not be able to continue with this request. Please wait until next month, when your request allowance will be reset." & vbNewLine & vbNewLine & "Think this is an Error?" & vbNewLine & "Contac us at NewSuppliers#Hewden.co.uk to make an appeal.", vbOKOnly, "Important Notice!")
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("P:\ttp.txt", True)
a.WriteLine (strPassword)
a.Close
End If

Batch faxing with Excel control of re-try attempts

I use CDO to email faxes to efax.co.uk. I send multiple faxes at one time (maybe up to 10) to the same fax number. The problem is efax reports most of the faxes I send as unsuccessful because the fax number is busy (guess what, busy sending my faxes). I checked with efax, it's not possible to configure the re-try time nor to queue faxes to the same number.
Therefore I would like to create a separate instance of Excel (maybe using CreateObject("excel.application") ), that has the background batch processing macro. This second instance I need to:
reference the worksheet in the first instance of Excel, for the list of faxes to be sent.
send the email/fax, again referencing information in the first instance.
change the colour of a cell in first instance to show it has sent the fax.
When I start the computer and open the first instance, I would like it automatically to start the second instance. Thus when I close the first instance I would like it to close the second instance also.
The macro I currently use to send faxes:
Sub faxTPD()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
vuser = Environ("USERNAME")
vweek = Format(range("ThisWeek"), "yymmdd")
vtenant = range("tblaccounts").ListObject.ListColumns("Name").DataBodyRange(range("statementrow"))
Application.StatusBar = "FAX TPD: " & vtenant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxx#yahoo.co.uk"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxxx"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
strbody = "Hello Third Party Deduction Team," & vbNewLine & vbNewLine & _
"Please find following Third Party Deduction Application and Rent Schedule for welfare benefit tenant " & vtenant & "." & vbNewLine & vbNewLine & _
"Regards" & vbNewLine & _
"Pritchard Property" & vbNewLine & _
"T: xxxxxxx" & vbNewLine & _
"E: xxxxxxxx#yahoo.co.uk" & vbNewLine & _
"W: http://www.xxxxx"
vpath = "C:\Users\" & vuser & "\Google Drive\WR Tenant Statements\DWP\" & vweek
With iMsg
Set .Configuration = iConf
.To = "441978xxxxxx#efaxsend.com"
.CC = ""
.BCC = ""
.From = """Pritchard Property"" <xxxxxxx#yahoo.co.uk>"
.Subject = "Third Party Deduction Application for Welfare Benefit Tenant " & vtenant
.TextBody = strbody
.addattachment vpath & "\" & vtenant & " DWP TPD.pdf" ' DWP TPD request arrears payment £3.65
.addattachment vpath & "\" & vtenant & " Rent Schedule.pdf" ' Rent Schedule
If range("tblaccounts").ListObject.ListColumns("AST").DataBodyRange(range("statementrow")) <> "" Then
.addattachment range("tblaccounts").ListObject.ListColumns("AST").DataBodyRange(range("statementrow")) ' AST
End If
If range("tblaccounts").ListObject.ListColumns("DWP TPD").DataBodyRange(range("statementrow")) <> "" Then
.addattachment range("tblaccounts").ListObject.ListColumns("DWP TPD").DataBodyRange(range("statementrow")) ' DWP TPD permission
End If
.Send
End With
End Sub
Applcation.OnTime might be the way to go here. You can schedule a procedure to run at a certain time in the future. In the meantime, Excel works normally and the user can continue working. If you want to send faxes every five minutes until you've sent them all, it might look like this
'Create variables that don't lose scope until the workbook is closed
Public gvaTenants As Variant
Public glTenant As Long
Sub StartFaxes()
'put all the tenants in an 2d array
gvaTenants = Sheet1.ListObjects(1).ListColumns("name").DataBodyRange.Value
'start with the first tentant
glTenant = 1
SendOneFax
End Sub
Sub SendOneFax()
Dim sBody As String
'Send the first fax
' Some CDO setup stuff
sBody = "Dear " & gvaTenants(glTenant, 1) & ":" & vbNewLine & "Rest of message"
' Finish up CDO stuff and send
'increment to the next tenant
glTenant = glTenant + 1
'if we haven't sent the last one, schedule VBA to run this code
'again in five minutes
If glTenant <= UBound(gvaTenants, 1) Then
Application.OnTime Now + TimeSerial(0, 5, 0), "SendOneFax"
End If
'During the five minutes between runs, the user can Excel normally.
'the next time it runs, the user will have to wait a few secs for it to finish
End Sub

Resources