Asator
04-13-2011, 06:55 AM
Basically I have a macro that allows a user to multi-select a bunch of messages, and it will archive all of the attachments based on the sender's email address, and date/time received (basically in the structure vendor\date\filename.time.ext).
It seems to work properly, but PDF printing is having problems. When she multi-selects a handful (say 7-10) and runs the macro, it goes through with no errors, all the files get archived, but a random selection of the attachments don't get printed. Like I said, no errors. I tried adding Do...Loops to try and make sure the shell command returns a valid process id for acrord32.exe, buts still failing. I also added a 2 second sleep timer before it attempts to run a print job.
I'm at my wits end on this. How can I make sure all these files get printed?
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Public Sub PrintArchiveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim olAtts As Object
Dim xlApp As Object 'MS Excel, excel.application
Dim selPath As String, dn_sender As String, full_sender As String, sender_folder As String, _
AttFileSaveAs As String, AttName As String, AttExt As String, rtFolder As String, AcroPath As String, _
dStr As String
Dim i As Long, lngCount As Long
Dim DLFileExists As Boolean, extfound As Boolean, msgDelFlag As Boolean, prFlag As Boolean
Dim newrow As Integer, pDelay As Integer
Dim RetVal As Variant
'========================================================================== =======================
'User specific settings go here |
'========================================================================== =======================
'SET ROOT FOLDER HERE '|
rtFolder = "C:\path" '|
'Delete messages after archiving? '|
msgDelFlag = False '|
'Enable printing '|
prFlag = False '|
'path to adobe acrobat '|
AcroPath = "C:\Program Files\Adobe\Reader 8.0\Reader" '|
'Print delay '|
pDelay = 2000 '|
'========================================================================== =======================
If Right(rtFolder, 1) <> "\" Then rtFolder = rtFolder & "\"
If Right(AcroPath, 1) <> "\" Then AcroPath = AcroPath & "\"
'Verify root folder. If does not exist, abort.
If Dir(rtFolder) = "" Then
MsgBox "Folder not found: " & rtFolder
GoTo cleanup
End If
'Define ActiveX connection to Outlook, and define selection range
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
'Create ActiveX connection to Excel
Set xlApp = CreateObject("Excel.Application")
'Check for existing DomLookup file, if not, create
If Dir(rtFolder & "DomLookup.xls") <> "" Then
xlApp.workbooks.Open (rtFolder & "DomLookup.xls")
Else
'Create file
xlApp.workbooks.Add
xlApp.activeworkbook.SaveAs FileName:=rtFolder & "DomLookup.xls"
xlApp.workbooks("DomLookup.xls").sheets(3).Delete
xlApp.workbooks("DomLookup.xls").sheets(2).Delete
With xlApp.workbooks("DomLookup.xls").sheets(1)
xlApp.workbooks("DomLookup.xls").names.Add Name:="DomLU", refersto:=.Range("A:B")
.Range("A:B").Locked = False
.cells(1, 4).Locked = False
.cells(1, 5).formular1c1 = "=if(iserror(vlookup(RC[-1],domlu,2,0))," & Chr(34) & "Error" & Chr(34) & ",vlookup(RC[-1],domlu,2,0))"
.Range("C:Z").interior.colorindex = 15
.Range("C:Z").interior.Pattern = xlLightUp
.protect Password:="DomLU", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
xlApp.workbooks("DomLookup.xls").protect Password:="DomLU", Structure:=True, windows:=False
xlApp.workbooks("DomLookup.xls").Save
End If
For Each objMsg In objSelection
'extract domain name
full_sender = objMsg.SenderEmailAddress
dStr = Format(objMsg.SentOn, "yyyy_mm_dd")
If InStr(full_sender, "Company") <> 0 Or InStr(full_sender, "company") <> 0 Or InStr(full_sender, "COMPANY") <> 0 Then
sender_folder = "Company"
Else
dn_sender = Right(full_sender, Len(full_sender) - InStr(full_sender, "@"))
'check for commonly-used ISP/free email domains. if matched, use FULL email address for lookup.
Select Case dn_sender
Case "gmail.com", "bellsouth.net", "bellsouth.com", "yahoo.com", "hotmail.com", "comcast.net", "rr.com", "sbcglobal.net", "aol.com", "aim.com", _
"gmx.com", "inbox.com", "mail.com", "att.net", "att.com"
dn_sender = full_sender
End Select
xlApp.workbooks("domlookup.xls").sheets(1).cells(1, 4).Value = dn_sender
sender_folder = xlApp.workbooks("domlookup.xls").sheets(1).cells(1, 5).Value
End If
'Could not find entry for specified domain, add new entry
If sender_folder = "Error" Then
GotFolder = False
selPath = SelectFolder("no DomLookup.xls entry for " & dn_sender & " (domain not recognized), select folder to save to", rtFolder)
If Right(selPath, 1) = "\" Then selPath = Left(selPath, Len(selPath) - 1)
For j = Len(selPath) To 1 Step -1
If Mid(selPath, j, 1) = "\" And GotFolder = False Then
selPath = Right(selPath, Len(selPath) - j)
GotFolder = True
sender_folder = selPath
End If
Next j
With xlApp.workbooks("DomLookup.xls").sheets(1)
newrow = .usedrange.rows.Count + 1
.cells(newrow, 1).Value = dn_sender
.cells(newrow, 2).Value = selPath
End With
'sender_folder = "Unknown"
'MsgBox "Warning: " & dn_sender & " not recognized, placing files in Unknown folder."
sender_folder = xlApp.workbooks("domlookup.xls").sheets(1).cells(1, 5).Value
End If
Set olAtts = objMsg.Attachments
If olAtts.Count > 0 Then
On Error Resume Next
'check for sender folder, if doesn't exist, make it
If Dir(rtFolder & sender_folder, vbDirectory) = "" Then
MkDir rtFolder & sender_folder
End If
'check for date subfolder, if doesn't exist, make it
If Dir(rtFolder & sender_folder & "\" & dStr, vbDirectory) = "" Then
MkDir rtFolder & sender_folder & "\" & dStr
End If
Err.Clear
'Begin stepping through attachments
For j = 1 To olAtts.Count
extfound = False
For k = Len(olAtts(j)) To 1 Step -1
If Mid(olAtts(j), k, 1) = "." And extfound = False Then
'extension determined, go with it
AttName = Left(olAtts(j), k - 1)
AttExt = Right(olAtts(j), Len(olAtts(j)) - k + 1)
extfound = True
End If
Next k
'set file name structure
AttFileSavename = AttName & "_" & Format(objMsg.SentOn, "hh.mm.ss") & AttExt
olAtts(j).SaveAsFile rtFolder & sender_folder & "\" & dStr & "\" & AttFileSavename
Select Case LCase(AttExt)
Case ".jpg", ".gif", ".png", ".bmp"
'do nothing
Case ".pdf"
If prFlag = True Then
RetVal = Null
Do Until IsNumeric(RetVal) And RetVal <> 0
Call Sleep(pDelay)
DoEvents
RetVal = Shell(AcroPath & "AcroRd32.exe /t /h " & Chr(34) & rtFolder & sender_folder & "\" & dStr & "\" & AttFileSavename & Chr(34))
'Print using acrobat reader, since for some reason we don't have the shell extension
Loop
End If
Case Else
If prFlag = True Then
RetVal = Null
Do Until RetVal = 2 Or RetVal = 31 Or RetVal > 32
Call Sleep(pDelay)
DoEvents
RetVal = ShellExecute(0, "print", rtFolder & sender_folder & "\" & dStr & "\" & AttFileSavename, "", "", 1)
'Print using shell extension
Loop
End If
End Select
Next j
If Err.Number = 0 And msgDelFlag = True Then 'did the user specify these messages be deleted?
objMsg.Delete
ElseIf Err.Number <> 0 And msgDelFlag = True Then 'Don't delete if there was an error somewhere
MsgBox "Unable to save or print message from " & full_sender & " at " & objMsg.SentOn & vbNewLine _
& "Error number: " & Err.Number & " (" & Err.Description & ")" & vbNewLine _
& "Message will not be deleted."
End If
End If
Next objMsg
'clean up
cleanup:
xlApp.workbooks("domlookup.xls").Save
xlApp.workbooks("domlookup.xls").Close False
xlApp.Quit
Set xlApp = Nothing
Set objOL = Nothing
Set objMsg = Nothing
Set objAttachments = Nothing
Set objSelection = Nothing
Set olAtt = Nothing
End Sub
Function SelectFolder(Optional Title As String, Optional TopFolder As String) As String
Dim objShell As New Shell32.Shell
Dim objFolder As Shell32.Folder
'If you use 16384 instead of 1 on the next line,
'files are also displayed
Set objFolder = objShell.BrowseForFolder(0, Title, 1, TopFolder)
If Not objFolder Is Nothing Then
SelectFolder = objFolder.Items.Item.Path
End If
End Function
It seems to work properly, but PDF printing is having problems. When she multi-selects a handful (say 7-10) and runs the macro, it goes through with no errors, all the files get archived, but a random selection of the attachments don't get printed. Like I said, no errors. I tried adding Do...Loops to try and make sure the shell command returns a valid process id for acrord32.exe, buts still failing. I also added a 2 second sleep timer before it attempts to run a print job.
I'm at my wits end on this. How can I make sure all these files get printed?
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Public Sub PrintArchiveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim olAtts As Object
Dim xlApp As Object 'MS Excel, excel.application
Dim selPath As String, dn_sender As String, full_sender As String, sender_folder As String, _
AttFileSaveAs As String, AttName As String, AttExt As String, rtFolder As String, AcroPath As String, _
dStr As String
Dim i As Long, lngCount As Long
Dim DLFileExists As Boolean, extfound As Boolean, msgDelFlag As Boolean, prFlag As Boolean
Dim newrow As Integer, pDelay As Integer
Dim RetVal As Variant
'========================================================================== =======================
'User specific settings go here |
'========================================================================== =======================
'SET ROOT FOLDER HERE '|
rtFolder = "C:\path" '|
'Delete messages after archiving? '|
msgDelFlag = False '|
'Enable printing '|
prFlag = False '|
'path to adobe acrobat '|
AcroPath = "C:\Program Files\Adobe\Reader 8.0\Reader" '|
'Print delay '|
pDelay = 2000 '|
'========================================================================== =======================
If Right(rtFolder, 1) <> "\" Then rtFolder = rtFolder & "\"
If Right(AcroPath, 1) <> "\" Then AcroPath = AcroPath & "\"
'Verify root folder. If does not exist, abort.
If Dir(rtFolder) = "" Then
MsgBox "Folder not found: " & rtFolder
GoTo cleanup
End If
'Define ActiveX connection to Outlook, and define selection range
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
'Create ActiveX connection to Excel
Set xlApp = CreateObject("Excel.Application")
'Check for existing DomLookup file, if not, create
If Dir(rtFolder & "DomLookup.xls") <> "" Then
xlApp.workbooks.Open (rtFolder & "DomLookup.xls")
Else
'Create file
xlApp.workbooks.Add
xlApp.activeworkbook.SaveAs FileName:=rtFolder & "DomLookup.xls"
xlApp.workbooks("DomLookup.xls").sheets(3).Delete
xlApp.workbooks("DomLookup.xls").sheets(2).Delete
With xlApp.workbooks("DomLookup.xls").sheets(1)
xlApp.workbooks("DomLookup.xls").names.Add Name:="DomLU", refersto:=.Range("A:B")
.Range("A:B").Locked = False
.cells(1, 4).Locked = False
.cells(1, 5).formular1c1 = "=if(iserror(vlookup(RC[-1],domlu,2,0))," & Chr(34) & "Error" & Chr(34) & ",vlookup(RC[-1],domlu,2,0))"
.Range("C:Z").interior.colorindex = 15
.Range("C:Z").interior.Pattern = xlLightUp
.protect Password:="DomLU", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
xlApp.workbooks("DomLookup.xls").protect Password:="DomLU", Structure:=True, windows:=False
xlApp.workbooks("DomLookup.xls").Save
End If
For Each objMsg In objSelection
'extract domain name
full_sender = objMsg.SenderEmailAddress
dStr = Format(objMsg.SentOn, "yyyy_mm_dd")
If InStr(full_sender, "Company") <> 0 Or InStr(full_sender, "company") <> 0 Or InStr(full_sender, "COMPANY") <> 0 Then
sender_folder = "Company"
Else
dn_sender = Right(full_sender, Len(full_sender) - InStr(full_sender, "@"))
'check for commonly-used ISP/free email domains. if matched, use FULL email address for lookup.
Select Case dn_sender
Case "gmail.com", "bellsouth.net", "bellsouth.com", "yahoo.com", "hotmail.com", "comcast.net", "rr.com", "sbcglobal.net", "aol.com", "aim.com", _
"gmx.com", "inbox.com", "mail.com", "att.net", "att.com"
dn_sender = full_sender
End Select
xlApp.workbooks("domlookup.xls").sheets(1).cells(1, 4).Value = dn_sender
sender_folder = xlApp.workbooks("domlookup.xls").sheets(1).cells(1, 5).Value
End If
'Could not find entry for specified domain, add new entry
If sender_folder = "Error" Then
GotFolder = False
selPath = SelectFolder("no DomLookup.xls entry for " & dn_sender & " (domain not recognized), select folder to save to", rtFolder)
If Right(selPath, 1) = "\" Then selPath = Left(selPath, Len(selPath) - 1)
For j = Len(selPath) To 1 Step -1
If Mid(selPath, j, 1) = "\" And GotFolder = False Then
selPath = Right(selPath, Len(selPath) - j)
GotFolder = True
sender_folder = selPath
End If
Next j
With xlApp.workbooks("DomLookup.xls").sheets(1)
newrow = .usedrange.rows.Count + 1
.cells(newrow, 1).Value = dn_sender
.cells(newrow, 2).Value = selPath
End With
'sender_folder = "Unknown"
'MsgBox "Warning: " & dn_sender & " not recognized, placing files in Unknown folder."
sender_folder = xlApp.workbooks("domlookup.xls").sheets(1).cells(1, 5).Value
End If
Set olAtts = objMsg.Attachments
If olAtts.Count > 0 Then
On Error Resume Next
'check for sender folder, if doesn't exist, make it
If Dir(rtFolder & sender_folder, vbDirectory) = "" Then
MkDir rtFolder & sender_folder
End If
'check for date subfolder, if doesn't exist, make it
If Dir(rtFolder & sender_folder & "\" & dStr, vbDirectory) = "" Then
MkDir rtFolder & sender_folder & "\" & dStr
End If
Err.Clear
'Begin stepping through attachments
For j = 1 To olAtts.Count
extfound = False
For k = Len(olAtts(j)) To 1 Step -1
If Mid(olAtts(j), k, 1) = "." And extfound = False Then
'extension determined, go with it
AttName = Left(olAtts(j), k - 1)
AttExt = Right(olAtts(j), Len(olAtts(j)) - k + 1)
extfound = True
End If
Next k
'set file name structure
AttFileSavename = AttName & "_" & Format(objMsg.SentOn, "hh.mm.ss") & AttExt
olAtts(j).SaveAsFile rtFolder & sender_folder & "\" & dStr & "\" & AttFileSavename
Select Case LCase(AttExt)
Case ".jpg", ".gif", ".png", ".bmp"
'do nothing
Case ".pdf"
If prFlag = True Then
RetVal = Null
Do Until IsNumeric(RetVal) And RetVal <> 0
Call Sleep(pDelay)
DoEvents
RetVal = Shell(AcroPath & "AcroRd32.exe /t /h " & Chr(34) & rtFolder & sender_folder & "\" & dStr & "\" & AttFileSavename & Chr(34))
'Print using acrobat reader, since for some reason we don't have the shell extension
Loop
End If
Case Else
If prFlag = True Then
RetVal = Null
Do Until RetVal = 2 Or RetVal = 31 Or RetVal > 32
Call Sleep(pDelay)
DoEvents
RetVal = ShellExecute(0, "print", rtFolder & sender_folder & "\" & dStr & "\" & AttFileSavename, "", "", 1)
'Print using shell extension
Loop
End If
End Select
Next j
If Err.Number = 0 And msgDelFlag = True Then 'did the user specify these messages be deleted?
objMsg.Delete
ElseIf Err.Number <> 0 And msgDelFlag = True Then 'Don't delete if there was an error somewhere
MsgBox "Unable to save or print message from " & full_sender & " at " & objMsg.SentOn & vbNewLine _
& "Error number: " & Err.Number & " (" & Err.Description & ")" & vbNewLine _
& "Message will not be deleted."
End If
End If
Next objMsg
'clean up
cleanup:
xlApp.workbooks("domlookup.xls").Save
xlApp.workbooks("domlookup.xls").Close False
xlApp.Quit
Set xlApp = Nothing
Set objOL = Nothing
Set objMsg = Nothing
Set objAttachments = Nothing
Set objSelection = Nothing
Set olAtt = Nothing
End Sub
Function SelectFolder(Optional Title As String, Optional TopFolder As String) As String
Dim objShell As New Shell32.Shell
Dim objFolder As Shell32.Folder
'If you use 16384 instead of 1 on the next line,
'files are also displayed
Set objFolder = objShell.BrowseForFolder(0, Title, 1, TopFolder)
If Not objFolder Is Nothing Then
SelectFolder = objFolder.Items.Item.Path
End If
End Function