Macro needed

Our Sales department send out quite a lot of emails with a price list attached. We have separate price lists for each of our product ranges, and each of the price lists is available in several currencies.

To save a bit of time, it would be nice to have a macro attached to a keyboard shortcut which opens the Insert Attachment dialog and displays the folder where the price lists are stored. For instance, I have set up a P: drive where all the price lists are stored. So it would be great if the user could press Ctrl->P and the Insert Attachment dialog would pop up and show the contents of the P: drive so that the user could choose the appropriate price list.
Who is Participating?
Strangely Outlook VBA doesn't have this dialog programmed for you (like Excel does already), so you need to add a Class Module:

Private Declare Function GetOpenFileName Lib _
   "comdlg32.dll" Alias "GetOpenFileNameA" _
   (pOFStruct As OFStruct) As Long

 Private Type OFStruct
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   lpstrFile As String
   nMaxFile As Long
   lpstrFileTitle As String
   nMaxFileTitle As Long
   lpstrInitialDir As String
   lpstrTitle As String
   flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
 End Type

 Private pstrFileName As String
 Private pstrFileTitle As String
 Private pstrInitDir As String
 Private pstrFilter As String
 Private pintFilterIndex As Integer
 Private pstrDialogTitle As String
 Private plngFlags As Long

 Public Property Let FileName(strName As String)
   pstrFileName = strName
 End Property

 Public Property Get FileName() As String
   FileName = pstrFileName
 End Property

 Public Property Get FileTitle() As String
   FileTitle = pstrFileTitle
 End Property

 Public Property Let InitDir(strName As String)
   pstrInitDir = strName
 End Property

 Public Property Get InitDir() As String
   InitDir = pstrInitDir
 End Property

 Public Property Let Filter(strName As String)
   pstrFilter = strName
 End Property

 Public Property Get Filter() As String
   Filter = pstrFilter
 End Property

 Public Property Get FilterIndex() As Integer
   FilterIndex = pintFilterIndex
 End Property

 Public Property Let FilterIndex(intNum As Integer)
   pintFilterIndex = intNum
 End Property

 Public Property Let DialogTitle(strName As String)
   pstrDialogTitle = strName
 End Property

 Public Property Get DialogTitle() As String
   DialogTitle = pstrDialogTitle
 End Property

 Public Property Let flags(lngNum As Long)
   plngFlags = lngNum
 End Property

 Public Property Get flags() As Long
   flags = plngFlags
 End Property

 Public Function OpenDialog() As Boolean
   Dim OpenFile As OFStruct
   Dim lngRet As Long

   With OpenFile
     .lStructSize = Len(OpenFile)
     .lpstrFilter = Replace(pstrFilter, "|", vbNullChar) & vbNullChar
     .nFilterIndex = pintFilterIndex
     .lpstrFile = pstrFileName & String$(512 - Len(pstrFileName), 0)
     .nMaxFile = Len(.lpstrFile) - 1
     .lpstrFileTitle = String$(.nMaxFile, 0)
     .nMaxFileTitle = .nMaxFile
     .lpstrInitialDir = pstrInitDir
     .lpstrTitle = pstrDialogTitle
     .flags = plngFlags
   End With
   lngRet = GetOpenFileName(OpenFile)
   If lngRet = 0 Then
     pstrFileName = ""
     pstrFileTitle = ""
     pstrFileName = Left$(OpenFile.lpstrFile, InStr(OpenFile.lpstrFile, vbNullChar) - 1)
     pstrFileTitle = Left$(OpenFile.lpstrFileTitle, InStr(OpenFile.lpstrFileTitle, vbNullChar) - 1)
   End If
   OpenDialog = lngRet
 End Function


Private Sub Class_Initialize()

End Sub

Open in new window

Then add a module:

Public Sub AddAttachment()

    Dim cls As New Class1
     Dim strFile As String

     On Error GoTo ErrHandler

     If TypeName(ActiveWindow) = "Inspector" Then
         If Not ActiveInspector.CurrentItem.Class = olMail Then
             MsgBox "This item is not an e-mail message.", vbExclamation
             cls.Filter = "All files|*.*"
             cls.InitDir = "P:\"
             If cls.OpenDialog Then
                 strFile = cls.FileName
                 ActiveInspector.CurrentItem.Attachments.Add strFile
             End If
         End If
     ElseIf TypeName(ActiveWindow) = "Explorer" Then
         MsgBox "Please open an e-mail message and try again.", vbInformation
     End If

     Set cls = Nothing
     Exit Sub

     MsgBox Err.Description, vbExclamation
     Resume ExitHandler
 End Sub


Open in new window

Please note, there's a mentioning of "Dim cls As New Class1", this Class1 is the name of the Class Module you added. In case there were already more, the name is probably Classxx (where xx is a higher number), change the line of code accordingly.

After you tested it works, assign a button to this macro (as there are not hot key assignments in Outlook).
TownTalkAuthor Commented:
That's great. Thanks for your help :)
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.