Private Sub Application_NewMail() '** Added by T. Lewis - commented out by R. Longo 'VERSION 1.0 CLASS 'BEGIN ' MultiUse = -1 'True 'End 'Attribute VB_Name = "ThisOutlookSession" 'Attribute VB_GlobalNameSpace = False 'Attribute VB_Creatable = False 'Attribute VB_PredeclaredId = True 'Attribute VB_Exposed = True 'Option Explicit '** Dim fso As New FileSystemObject Dim fil As File Dim strReply As String Dim strBody As String Dim strTempFile As String Dim TS As TextStream Dim sOrderID As String Dim objFolder As MAPIFolder Set objFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' A temporary variable that is completely worthless. Dim strTemp As String ' Note that in order to look at the most-recently received message, we need to sort the items ' by the time they were received, in decending order. This step is CRITICAL; without it, you cannot rely ' upon the items being arranged in any particular order. In my experiments, the way that the items were ' sorted within Outlook (for example, by "From" or by "Subject") affected which message appeared at the ' beginning of the collection, and which one appeared at the end. objFolder.Items.Sort "Received", True ' Somewhere down the line we will be creating an instance of the Word application. Since we don't ' necessarily want to be creating and destroying it every time, we will set a global flag for this ' routine to indicate whether it has already been created or not. Dim IsWordCreated As Boolean ' The default value for this flag will be False. Not every email will have an attachment that ' requires an instance of Word. IsWordCreated = False ' Create a MailItem object which we will use to enumerate through the collection Dim objNewMail As MailItem Dim objReplyMail As MailItem For Each objNewMail In objFolder.Items ' It is possible that a single NewMail event could be triggered by the arrival of multiple messages. ' We are only interested in unread messages, so we will use the UnRead property as the condition for ' continuing through our collection. We will not be evaulating EVERY message; If objNewMail.UnRead Then 'Process if doc not read yet (opened) Dim strSender As String Dim sDateTime As String Dim colAttachments As Attachments ' a collection Set colAttachments = objNewMail.Attachments ' Create an enumeration variable to iterate through the Attachments collection Dim objAttachment As Attachment For Each objAttachment In colAttachments ' We are only concerned with Orange County Corporate Courier documents If Left(objAttachment.FileName, 4) = "OCCC" And Right(objAttachment.FileName, 3) = "doc" Then 'Now we make sure we didn't already process this email sDateTime = CStr(objNewMail.ReceivedTime) iprocessed = CheckLog(sDateTime) If iprocessed = 0 Then ' We will be creating a temporary file, so we need a value for its filename Dim strFileName As String Dim strOrder As String ' Create our temporary file in the C:\Temp directory, in the form of index, ' where index is the document's location within the Attachments collection. Note that with this ' code, it is possible for files to be overwritten, which is acceptable. strTempFile = "C:\Temp\TempDoc_" & objAttachment.Index & ".doc" ' Save our attachment to the temp directory using our filename variable objAttachment.SaveAsFile strTempFile ' Create an instance of a Word application Dim appWord As Word.Application ' Check our global flag. If an instance of Word has not been created, then we need ' to do so now. If Not IsWordCreated Then ' Create an instance of the application Set appWord = CreateObject("Word.Application") ' Be sure our flag is now set IsWordCreated = True End If ' Instance of Word check ' Now open our document in Word appWord.Documents.Open strTempFile 'Get the next invoice number, increment number, and save for the next order Set TS = fso.OpenTextFile("c:\my documents\orders\sequence.txt", ForReading) sOrderID = TS.ReadLine lNum = CLng(sOrderID) lNum = lNum + 1 sOrderID = CStr(lNum) TS.Close fso.DeleteFile ("c:\my documents\orders\sequence.txt") Set TS = fso.CreateTextFile("c:\my documents\orders\sequence.txt") TS.WriteLine sOrderID TS.Close ' Look for our bookmarks, which in this case we will presume it is there '** document security code Dim lngProtectType As Long lngProtectType = appWord.ActiveDocument.ProtectionType appWord.ActiveDocument.Unprotect Dim rngBookmark As Range appWord.ActiveDocument.Bookmarks("lngOrderID").Range.InsertAfter sOrderID 'rngBookmark.Text = sOrderID Set rngBookmark = Nothing sSender = appWord.ActiveDocument.Bookmarks.Item("sSenderName").Range.Text 'parse the text to remove the 'FORMTEXT' prefix If Len(sSender) > 11 Then sSender = Mid$(sSender, 11) Else sSender = "" End If appWord.ActiveDocument.Protect Type:=lngProtectType, NoReset:=True ' Save our document with its changes. strFileName = "C:\My Documents\orders\OCCC_" & sSender & "_" & sOrderID & ".doc" appWord.ActiveDocument.SaveAs FileName:=strFileName appWord.ActiveDocument.PrintOut '* Added by Russell *' '* Send a reply message. This method will not fire off the '* dreaded Accounts Security Dialog Box (tested in Outlook 2000) strReply = "OCC Courier order number: " & sOrderID strBody = "Your request has been received, assigned invoice number " & sOrderID & ", and scheduled for pickup and/or delivery." strBody = strBody & " Please print two copies - attach one to package, and keep one copy for your files." & Chr(10) & Chr(13) strBody = strBody & "Please note: you should receive this reply message for each and every order document you send." strBody = strBody & " If you do not receive a reply, please call 949-474-9000." Set objReplyMail = objNewMail.Reply objReplyMail.Subject = strReply objReplyMail.Body = strBody objReplyMail.Attachments.Add strFileName objReplyMail.Send appWord.ActiveDocument.Close 'Since we have dealt with this message by printing out the order form, we will mark the ' message as having been read. objNewMail.UnRead = False fso.DeleteFile (strTempFile) End If 'check to see that email is not in log End If ' objAttachment.FileName check Next ' Loop through the Attachments collection ' At this point, we're done with the loop, so we can start cleaning up our objects Set objAttachment = Nothing ' Destroy our collection object that its values do not accidentally persist between ' iterations of this same loop. Set colAttachments = Nothing End If 'End of body of code that processes emails with attachments Next ' For Each objNewMail. The loop will have exited already if it encountered a read message. ' If we have created an instance of the Word application, then we need to destroy it at this time. If IsWordCreated Then appWord.Quit Set appWord = Nothing End If ' Go ahead and clean up our remaining objects Set objNewMail = Nothing Set objReplyMail = Nothing Set objFolder = Nothing End Sub ' Application_NewMail Function CheckLog(sDateTime As String) As Integer Dim fso As New FileSystemObject Dim fil As File Dim sFileDateTime Dim TS As TextStream iEmailProcessed = 0 Set TS = fso.OpenTextFile("c:\My Documents\DateTimeLog.txt", ForReading) Do While Not TS.AtEndOfStream sFileDateTime = TS.ReadLine If sFileDateTime = sDateTime Then iEmailProcessed = 1 End If Loop TS.Close Set TS = fso.OpenTextFile("c:\My Documents\DateTimeLog.txt", ForAppending) If iEmailProcessed = 0 Then TS.WriteLine sDateTime End If TS.Close Set fso = Nothing CheckLog = iEmailProcessed End Function
|Need to script a password reset for multiple users in the same OU in Active Directory||3||50|
|"J" column have the (Q) original color on top of row given color when being refresh.||30||39|
|Does anyone have a sample vb script (or vba) that opens every .xls and .xlsx file in a directory and extracts certain cells||25||68|
|Only allow one site in Internet Explorer on XenApp.||9||50|
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
12 Experts available now in Live!