Jellybrain
Technical User
So i am in a bit of a pickle. i am new to programming all together. But here is my situation: Our company uses and IBM mainframe to process all the database queries. the mainframe doesnt interact well with the MS infrastructure we have today. They want it to folder the PDF reports it generates. the only way we have figure it how to dynamically do this is to send an email to a dummy client(email address) with a subject line that has the folder path and the attached PDF. the company currently used a macro that ran continuously in the background to folder these reports (PDF). if one had a bad subject line it would error out continuously until some happened to look at the PC off in a corner. so i suggested we use a rule script that only ran once per email. so if an email erred it only pop one message not 500+ if you didn't catch it. (the problem i have found with the rule scripts is that it can only be one "sub". Since i had the idea i got tasked with it. again this is my best effort at piece melding this together. Here is where I stand: I have the rule working when it comes to foldering the attachment based on the subject IF the path is there and no subject line error code. Added the if then for the error code on report "XX" added the create folder path part [highlight #FCE94F]but it will only create one folder.[/highlight] YOUR HELP IS GREATLY APPRECIATED.
Here is my Code:
-----------------------------------------------------------------------------------------------------
Public Sub SaveAttachments2(mail As Outlook.MailItem)
On Error GoTo GetAttachments_err
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim f As String
Dim strSubject As String
Dim w As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
strSubject = mail.Subject
f = strSubject
'check for bad subject lines and delete them.
If InStr(1, f, "XX") Then
mail.Delete
Exit Sub
End If
' MkDir ("Z:\OPERATIO\AS400_Report\" & f)
StrFolderPath = "Z:\Chuck_Norris\IBM_Mainframe\" & f & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
For Each Atmt In mail.Attachments
FileName = "Z:\Chuck_Norris\IBM_Mainframe\" & f & "\" & Atmt.FileName
'popup window to confirm its working for now. (currently commented out)
'MsgBox "Attachment and path " & Atmt.FileName, vbOKOnly, "What and Where"
Atmt.SaveAsFile FileName
i = i + 1
'to delete the item
Next Atmt
mail.Delete
GetAttachments_exit:
Set Atmt = Nothing
Exit Sub
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments2" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
-----------------------------------------------------------------------------------------------------------------
I have tried working with something like this:
------------------------------------------------------------------------------------------------------------------
strNewFolder = ""
Do Until strPath = strNewFolder
strNewFolder = Left(strPath, InStr(Len(strNewFolder) + 1, strPath, "\"))
If objFileSys.FolderExists(strNewFolder) = False Then
objFileSys.CreateFolder(strNewFolder)
End If
Loop
------------------------------------------------------------------------------------------------------------------
Tried adding another if not then like in the code, but i cant seem to get it to work right with only one sub. Also as far as i can tell you have to have "mail As Outlook.MailItem" for it to show up in the rule > when email has an attachment > run script > click script > a list appears (macros don't show up).
"Public Sub SaveAttachments2(mail As Outlook.MailItem)
Here is my Code:
-----------------------------------------------------------------------------------------------------
Public Sub SaveAttachments2(mail As Outlook.MailItem)
On Error GoTo GetAttachments_err
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim f As String
Dim strSubject As String
Dim w As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
strSubject = mail.Subject
f = strSubject
'check for bad subject lines and delete them.
If InStr(1, f, "XX") Then
mail.Delete
Exit Sub
End If
' MkDir ("Z:\OPERATIO\AS400_Report\" & f)
StrFolderPath = "Z:\Chuck_Norris\IBM_Mainframe\" & f & "\"
If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If
For Each Atmt In mail.Attachments
FileName = "Z:\Chuck_Norris\IBM_Mainframe\" & f & "\" & Atmt.FileName
'popup window to confirm its working for now. (currently commented out)
'MsgBox "Attachment and path " & Atmt.FileName, vbOKOnly, "What and Where"
Atmt.SaveAsFile FileName
i = i + 1
'to delete the item
Next Atmt
mail.Delete
GetAttachments_exit:
Set Atmt = Nothing
Exit Sub
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments2" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
-----------------------------------------------------------------------------------------------------------------
I have tried working with something like this:
------------------------------------------------------------------------------------------------------------------
strNewFolder = ""
Do Until strPath = strNewFolder
strNewFolder = Left(strPath, InStr(Len(strNewFolder) + 1, strPath, "\"))
If objFileSys.FolderExists(strNewFolder) = False Then
objFileSys.CreateFolder(strNewFolder)
End If
Loop
------------------------------------------------------------------------------------------------------------------
Tried adding another if not then like in the code, but i cant seem to get it to work right with only one sub. Also as far as i can tell you have to have "mail As Outlook.MailItem" for it to show up in the rule > when email has an attachment > run script > click script > a list appears (macros don't show up).
"Public Sub SaveAttachments2(mail As Outlook.MailItem)
