Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'Declaration
Dim strSubject As String
Dim strSubjectA As String
Dim strPartN As String
Dim strShipDT As String
Dim strPO As String
Dim strDesc As String
Dim strPiec As String
Dim myOrtK As String
Dim myOrtG As String
Dim strA As String
Dim strRev As String
Dim Filename As String
Dim Prompt$
Dim myItems, myItem, myAttachments, myAttachment As Object
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
'Destination folder
myOrtK = "R:\CERTS\KOHLER"
myOrtG = "R:\CERTS\GENERAC"
On Error Resume Next
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
strSubject = Item.Subject
strA = Item.Subject
If strSubject = "KECCERT" Then
Prompt$ = "Do you want to send this Cert to Kohler?"
If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Attachment") = vbNo Then Exit Sub
strPartN = InputBox("Part Number", "Please insert Part number")
strShipDT = InputBox("Ship Date", "Please insert Ship date")
strPO = InputBox("P.O", "Please insert P.O number")
strRev = InputBox("Revision", "Please insert Revision")
Set Item = Outlook.Application.ActiveInspector.CurrentItem
Item.Subject = "PN_" + strPartN + "_SD_" + strShipDT + "_PO_" + strPO
strSubjectA = strA + strShipDT + strPartN + strRev
ElseIf strSubject = "GNCCERT" Then
Prompt$ = "Do you want to send this Cert to Generac?"
If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Attachment") = vbNo Then Cancel = True
strPartN = InputBox("Part Number", "Please insert Part number")
strDesc = InputBox("Part Description", "Please insert Part Description")
strPO = InputBox("P.O", "Please insert P.O number")
strPiec = InputBox("Number of Pieces", "Please insert number of Pieces")
strShipDT = InputBox("Ship Date", "Please insert Ship date")
strRev = InputBox("Revision", "Please insert Revision")
Set Item = Outlook.Application.ActiveInspector.CurrentItem
Item.Subject = strPartN + "," + strDesc + "," + strPO + "," + strPiec + "," + strShipDT
strSubjectA = strA + strShipDT + strPartN + strRev
On Error Resume Next
'for all items do...
For Each myItem In myOlSel
'point on attachments
Set myAttachments = myItem.Attachments
'if there are some...
If myAttachments.Count = 0 Then
Prompt$ = "There are no attachments. Do you want to send the message anyway?"
If MsgBox(Prompt$, vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for Attachment") = vbNo Then Exit Sub
'save them to destination
Filename = myOrtK & "\" & strSubjectA
myAttachments.SaveAsFile Filename
End If
Next
End If
'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub
