Thread: [Macros4outlook-users] Other macros

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 454-5900

Since this project is called "Macros for Outlook" and not just QuoteFix, I thought I would offer up 
a couple of macros that I had to make for myself (despite very little programming skill -- 
especially with VB) because they are sorely missing from Outlook.

The first is simply a form and macro to easily display a mail message's header information.  (Why 
does MS make that so difficult?)  I've attached a .zip of the text of the macro and the exported 
form files, but the macro text is also below.

========
Show Headers
========
Sub GetInetHeaders()
     ' Purpose: Returns the internet headers of a message.'
     Dim Msg As Outlook.mailItem
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set Msg = Application.ActiveWindow.CurrentItem
     End If
     Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
     Dim olkPA As Outlook.PropertyAccessor

     Set olkPA = Msg.PropertyAccessor
     EditText (olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS))
     Set olkPA = Nothing
End Sub

Sub EditText(sText As String)
Dim frm As ViewHeadersForm

Set frm = New ViewHeadersForm
frm.TextBox1.text = sText

frm.Show 'vbModal

End Sub

========
Form is attached (hope that's allowed)

Next, is a macro for generating a random, "fortune cookie" signature.  I wanted something similar to 
the "Signature Switch" Thunderbird add-on.  This was the best I could do.  It will create a fixed 
signature for your name and contact info and then append a randomly selected quote.  The quotes 
require a quotes file (defaulting to %userprofile%\Documents\EmailSigs.txt) that you create 
formatted with one quote/line and "\n" representing VBCrLf for when the signature is added.  The 
formatting is funny, but as I said, I'm no good at programming.

=======
Random Signature
=======
Option Explicit
Private Const strQuotesFileRelPath As String = "\Documents\EmailSigs.txt"
Private Const strFixedSigPart As String = vbCrLf _
         & "--" & vbCrLf _
         & "em...@ex...      Important Department" & vbCrLf _
         & "  888-555-1212           Corporate Entity" & vbCrLf _
         & vbCrLf

Sub NewMailMessage()
     Dim Msg As Outlook.MailItem

     Set Msg = Application.CreateItem(olMailItem)

     Call MakeSig(Msg)
     Msg.Display
     Set Msg = Nothing
End Sub

Sub SwapSig()
     Dim Msg As Outlook.MailItem
     If TypeName(Application.ActiveWindow) = "Inspector" Then
         Set Msg = Application.ActiveWindow.CurrentItem
     End If

     Dim strSigLine As String
     strSigLine = InStrRev(Msg.Body, ("--" & vbCrLf))
     If strSigLine <> 0 Then
         Msg.Body = Left(Msg.Body, strSigLine - 3)
     End If
     Call MakeSig(Msg)
End Sub

Private Sub MakeSig(ByVal Msg As MailItem)
     Dim numLines As Integer
     Dim strFilePath As String
     Dim arrLines() As String
     Dim intRandom As Integer

     numLines = 0
     strFilePath = Environ$("userprofile") & strQuotesFileRelPath

     If Dir(strFilePath) <> "" Then
         ' Open the file for reading
         Open strFilePath For Input As #1

         ' Go over each line in the file and save it in the array + count it
         Do Until EOF(1)
             ReDim Preserve arrLines(numLines + 1)
             Line Input #1, arrLines(numLines)
             numLines = numLines + 1
         Loop

         Close #1
     Else
         MsgBox ("Quotes file wasn't found!")
     End If

     ' Initalize the RNG seed based on system clock
     Randomize

     ' Get the random line number
     intRandom = Int(numLines * Rnd()) + 1

     ' Insert the random quote
     Msg.Body = Msg.Body & strFixedSigPart
     Msg.Body = Msg.Body & Replace(arrLines(intRandom), "\n", vbCrLf)

End Sub

========

Even though this project appears to be largely forgotten, I've really appreciated how it makes 
Outlook behave a bit like it should.  I hope someone finds these useful.

T

Thread: [Macros4outlook-users] Other macros

macros4outlook-users