WolfB
09-10-2014, 09:09 AM
Howdy all,
I have an existing VBA module that moves service reports I get to folders on my hard drive.
I recently got a new work laptop with Win7 (was on WinXP).
Someone helped me with this code long ago, so I don't take the credit for it.
Instead of saving service reports to a folder the VBA created if it doesn't already exist like this:
C:/Service Reports/Customer Name/System ID
It now creates and saves the service report to:
C:/Service ReportCustomer Name/System ID <-- where Service Report and Customer Name are jammed together into 1 folder name.
Any thoughts?
Here is the code:
Option Explicit
Private olAttach As Attachment
Private strFilename As String
Private vFolderName As Variant
Private strFolderName As String
Private strSubFolderName As String
Private Const strRootPath As String = "C:\SERVICE REPORTS"
Sub SavePDFAttachments(olItem As Outlook.MailItem)
On Error GoTo CleanUp
If InStr(1, olItem.Subject, "Beckman Coulter Service Report Task - Service Request") > 0 Then
vFolderName = Split(olItem.Subject, ",")
strFolderName = Trim(vFolderName(2)) & "\"
strSubFolderName = Replace(vFolderName(1), "System ID", "") & "\"
strFolderName = strRootPath & strFolderName & "\"
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Right(UCase(olAttach.FileName), 3) = "PDF" Then
If Not FolderExists(strFolderName) Then MkDir strFolderName
If Not FolderExists(strFolderName & strSubFolderName) Then MkDir strFolderName & strSubFolderName
olAttach.SaveAsFile strFolderName & strSubFolderName & olAttach.FileName
End If
Next olAttach
End If
End If
CleanUp:
Set olAttach = Nothing
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SavePDFAttachments olMsg
End Sub
I have an existing VBA module that moves service reports I get to folders on my hard drive.
I recently got a new work laptop with Win7 (was on WinXP).
Someone helped me with this code long ago, so I don't take the credit for it.
Instead of saving service reports to a folder the VBA created if it doesn't already exist like this:
C:/Service Reports/Customer Name/System ID
It now creates and saves the service report to:
C:/Service ReportCustomer Name/System ID <-- where Service Report and Customer Name are jammed together into 1 folder name.
Any thoughts?
Here is the code:
Option Explicit
Private olAttach As Attachment
Private strFilename As String
Private vFolderName As Variant
Private strFolderName As String
Private strSubFolderName As String
Private Const strRootPath As String = "C:\SERVICE REPORTS"
Sub SavePDFAttachments(olItem As Outlook.MailItem)
On Error GoTo CleanUp
If InStr(1, olItem.Subject, "Beckman Coulter Service Report Task - Service Request") > 0 Then
vFolderName = Split(olItem.Subject, ",")
strFolderName = Trim(vFolderName(2)) & "\"
strSubFolderName = Replace(vFolderName(1), "System ID", "") & "\"
strFolderName = strRootPath & strFolderName & "\"
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Right(UCase(olAttach.FileName), 3) = "PDF" Then
If Not FolderExists(strFolderName) Then MkDir strFolderName
If Not FolderExists(strFolderName & strSubFolderName) Then MkDir strFolderName & strSubFolderName
olAttach.SaveAsFile strFolderName & strSubFolderName & olAttach.FileName
End If
Next olAttach
End If
End If
CleanUp:
Set olAttach = Nothing
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SavePDFAttachments olMsg
End Sub