T
tomorrowsman
Hi there,
I have been using vba for only a short time, and I am trying to create
a code that will do a handful of things in Outlook; I hope I'm not in
over my head. First, I run a Rule that moves an incoming message
(based on sender) to another Outlook folder; this was easy enough, but
then:
1. If a subdirectory in a network folder does not exist, then create
one based on the date, then
2. Move the attachments in these messages to this dated network folder
subdirectory
3. If the attachments are a specific DisplayName ("PayData"), then
open an Excel workbook ("HrlyPRR.xls").
Voila!
Except, I can only get step 2 working. Step 3 would be the clincher,
while step 1 is more icing than vital; but I simply think I haven't
been immersed in vba long enough to crack this yet.
Here is my code so far (thanks to Sue Mosher for help on this):
Sub RunAScriptRuleRoutine(MyMail As MailItem)
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim msg As Outlook.MailItem
Dim myOrt As String
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set msg = olNS.GetItemFromID(strID)
Dim myAttachments As Object
Dim myMessage As Object
Set myAttachments = msg.Attachments
Dim v As Variant
Dim s As String
'create subdirectory based on date
x = Year(Date) & " " & Format(Month(Date), "00")
s = "M:\PD\Weekly.Rec"
If Dir(s & "\" & v & "\", vbDirectory) = "" Then
MkDir s & "\" & v & "\"
myOrt = s & "\" & v & "\"
End If
'save attachments to subdirectory
If myAttachments.Count > 0 Then
For i = 1 To myAttachments.Count
myAttachments(i).SaveAsFile "myOrt" & _
myAttachments(i).DisplayName
'if attachment name is "PayData.txt" then launch Excel
Set myMessage = Item
With myMessage
If .Attachments.Item.DisplayName = "PayData.txt" Then
Set objExcel = CreateObject("Excel.Application")
Set objWB = objExcel.Workbooks.Open("M:\PD\Weekly.Rec\HrlyPRR.xls")
objWB.Activate
End If
End With
Next i
End If
Set msg = Nothing
Set olNS = Nothing
End Sub
I have been using vba for only a short time, and I am trying to create
a code that will do a handful of things in Outlook; I hope I'm not in
over my head. First, I run a Rule that moves an incoming message
(based on sender) to another Outlook folder; this was easy enough, but
then:
1. If a subdirectory in a network folder does not exist, then create
one based on the date, then
2. Move the attachments in these messages to this dated network folder
subdirectory
3. If the attachments are a specific DisplayName ("PayData"), then
open an Excel workbook ("HrlyPRR.xls").
Voila!
Except, I can only get step 2 working. Step 3 would be the clincher,
while step 1 is more icing than vital; but I simply think I haven't
been immersed in vba long enough to crack this yet.
Here is my code so far (thanks to Sue Mosher for help on this):
Sub RunAScriptRuleRoutine(MyMail As MailItem)
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim msg As Outlook.MailItem
Dim myOrt As String
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set msg = olNS.GetItemFromID(strID)
Dim myAttachments As Object
Dim myMessage As Object
Set myAttachments = msg.Attachments
Dim v As Variant
Dim s As String
'create subdirectory based on date
x = Year(Date) & " " & Format(Month(Date), "00")
s = "M:\PD\Weekly.Rec"
If Dir(s & "\" & v & "\", vbDirectory) = "" Then
MkDir s & "\" & v & "\"
myOrt = s & "\" & v & "\"
End If
'save attachments to subdirectory
If myAttachments.Count > 0 Then
For i = 1 To myAttachments.Count
myAttachments(i).SaveAsFile "myOrt" & _
myAttachments(i).DisplayName
'if attachment name is "PayData.txt" then launch Excel
Set myMessage = Item
With myMessage
If .Attachments.Item.DisplayName = "PayData.txt" Then
Set objExcel = CreateObject("Excel.Application")
Set objWB = objExcel.Workbooks.Open("M:\PD\Weekly.Rec\HrlyPRR.xls")
objWB.Activate
End If
End With
Next i
End If
Set msg = Nothing
Set olNS = Nothing
End Sub