Solved

Form/Macro to create new message in outlook with prefilled subject line

Posted on 2009-07-03
5
1,516 Views
Last Modified: 2012-05-07
I am looking to create a macro of form which can be published to a group of users.  It would need to have 3 buttons which would create a new message with a prefilled subject line.

I.E

Button 1 creates a new blank message with the subject line <tag1>
Button 2 creates a new blank message with the subject line <sub2>

etc etc.

Is this possible?

0
Comment
Question by:MrBabbage
  • 3
  • 2
5 Comments
 

Author Comment

by:MrBabbage
Comment Utility
I have created Macros and a custom toolbar which works but I would like to publish a form to the Organizational Library so I can simply choose this form rather then manually making a macro and custom toolbar for each user.

Sub NewMail1()
Dim objOLApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Set objOLApp = New Outlook.Application
Set NewMail = objOLApp.CreateItem(olMailItem)
NewMail.Subject = "<test>"
NewMail.Display
End Sub
0
 
LVL 19

Expert Comment

by:darbid73
Comment Utility
The only way I know how to make this "publishable" to multiple users is to replace their  .OTM file (the file where all macros are save for Outlook) this would mean anything already there would be deleted.

The second is to create a Outlook Add-in.  To make this as simply as possible this would be a COM .dll.  You can do it in .NET as well.  Are you able (meaning will the computers accept) to distribute a .dll and register it on these people computers?  If yes then we could do a COM Add-in adding your own Outlook macro that you have developed.
0
 

Author Comment

by:MrBabbage
Comment Utility
Yes I have administrative rights on the computers so distributing and registering a .dll will not be a problem.
0
 

Author Comment

by:MrBabbage
Comment Utility
Sub New_Mail_Southend()
Dim objOLApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Set objOLApp = New Outlook.Application
Set NewMail = objOLApp.CreateItem(olMailItem)
NewMail.Subject = "<ins lhd>"
NewMail.Display
End Sub

Sub New_Mail_High_Wycombe()
Dim objOLApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Set objOLApp = New Outlook.Application
Set NewMail = objOLApp.CreateItem(olMailItem)
NewMail.Subject = "<ins cri-hw>"
NewMail.Display
End Sub

Ideally the above would be launchable from a toolbar with two buttons in outlook.
0
 
LVL 19

Accepted Solution

by:
darbid73 earned 500 total points
Comment Utility
Ok using VB6 it would be like this;

1. Make a new project - choose the "Addin" project
2. This will make a form and a designer
3.  You can delete the form
4.  you can delete all the code from the designer
5. In Designers you will have a module named Connect(Connect)
6.  Double click on this to get the Addin(Designer)
7. Add your name and description
8. Choose in this Case Application > Outllook  then Version > Outlook 11.0 then Load Behaviour > Startup
9. close that.
10. copy and past the following into this module
11. then File > Make yourname.dll
12 this will make the dll and register it on your computer.
13 if you open Outlook it should now load.
14.  In your project you will find the .dll file to distribute.
15.  To automatically register it I use a simple BAT file and I have added the code for that here as well.

You make a .BAT file with this below if you change the name to your dll and the dll is in the same folder as this .bat file then it will work with a shell call.

@echo off
%SYSTEMROOT%\system32\regsvr32 /s %0\..\YOURNAME.DLL

Once it is registered then you will find it here in the registry

HKEY_CURRENT_USER\Software\Microsoft\Office\Outlook\Addins

Option Explicit
 

Implements IDTExtensibility2
 
 
 

'all API calls here are only needed to have a transparent ICON for your buttons.

'this was directly copied from Microsoft

'It does not work properly if the target machine has office running in German
 
 

Public Type BITMAPINFOHEADER '40 bytes

   biSize As Long

   biWidth As Long

   biHeight As Long

   biPlanes As Integer

   biBitCount As Integer

   biCompression As Long

   biSizeImage As Long

   biXPelsPerMeter As Long

   biYPelsPerMeter As Long

   biClrUsed As Long

   biClrImportant As Long

End Type
 

Public Type BITMAP

   bmType As Long

   bmWidth As Long

   bmHeight As Long

   bmWidthBytes As Long

   bmPlanes As Integer

   bmBitsPixel As Integer

   bmBits As Long

End Type
 

' ===================================================================

'   GDI/Drawing Functions (to build the mask)

' ===================================================================

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _

  (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _

  (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _

  (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" _

  (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, _

   ByVal nBitCount As Long, lpBits As Any) As Long

Private Declare Function SelectObject Lib "gdi32" _

  (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _

  (ByVal hObject As Long) As Long

Private Declare Function GetBkColor Lib "gdi32" _

  (ByVal hdc As Long) As Long

Private Declare Function SetBkColor Lib "gdi32" _

  (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function GetTextColor Lib "gdi32" _

  (ByVal hdc As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" _

  (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function BitBlt Lib "gdi32" _

  (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _

   ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _

   ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function CreateHalftonePalette Lib "gdi32" _

  (ByVal hdc As Long) As Long

Private Declare Function SelectPalette Lib "gdi32" _

  (ByVal hdc As Long, ByVal hPalette As Long, _

   ByVal bForceBackground As Long) As Long

Private Declare Function RealizePalette Lib "gdi32" _

  (ByVal hdc As Long) As Long

Private Declare Function OleTranslateColor Lib "oleaut32.dll" _

  (ByVal lOleColor As Long, ByVal lHPalette As Long, _

   lColorRef As Long) As Long

Private Declare Function GetDIBits Lib "gdi32" _

  (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _

   ByVal nNumScans As Long, lpBits As Any, lpBI As Any, _

   ByVal wUsage As Long) As Long

Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _

  (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
 

' ===================================================================

'   Clipboard APIs

' ===================================================================

Private Declare Function OpenClipboard Lib "user32" _

  (ByVal hwnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function RegisterClipboardFormat Lib "user32" _

  Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long

Private Declare Function GetClipboardData Lib "user32" _

  (ByVal wFormat As Long) As Long

Private Declare Function SetClipboardData Lib "user32" _

  (ByVal wFormat As Long, ByVal hMem As Long) As Long

Private Declare Function EmptyClipboard Lib "user32" () As Long

Private Const CF_DIB = 8
 

' ===================================================================

'   Memory APIs (for clipboard transfers)

' ===================================================================

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _

  (pDest As Any, pSource As Any, ByVal cbLength As Long)

Private Declare Function GlobalAlloc Lib "kernel32" _

  (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function GlobalFree Lib "kernel32" _

  (ByVal hMem As Long) As Long

Private Declare Function GlobalLock Lib "kernel32" _

  (ByVal hMem As Long) As Long

Private Declare Function GlobalSize Lib "kernel32" _

  (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib "kernel32" _

  (ByVal hMem As Long) As Long

Private Const GMEM_DDESHARE = &H2000

Private Const GMEM_MOVEABLE = &H2
 
 
 

'start of the essential stuff
 

Public out_App As Object

Public out_AppInst As Object
 
 
 

Public WithEvents mycmdbar As Office.CommandBarButton  'this is the key for you wanting TWO you will need to have two with events for both buttons you make
 
 
 

Private Sub IDTExtensibility2_OnAddInsUpdate(custom() As Variant)

On Error GoTo Err_IDTExtensibility2_OnAddInsUpdate
 

    '<PLACEHOLDER - I AM NOT USING IT FOR DEMO, ONLY FOR COMPATIBILITY STANDARDS>

    'The OnAddInsUpdate method is called when a change occurs to the list of add-ins in the COM Add-Ins dialog box,

    'such as when an add-in is loaded or unloaded. The custom parameter is an array that can be used to provide

    'additional data to the OnAddInsUpdate method if desired.
 

Exit_IDTExtensibility2_OnAddInsUpdate:

    Exit Sub
 

Err_IDTExtensibility2_OnAddInsUpdate:

    MsgBox getMessage("errormsg", user_language) & Err.Number & " IDTExtensibility2_OnAddInsUpdate", vbCritical, "LuTTool Error"

    Resume Exit_IDTExtensibility2_OnAddInsUpdate

End Sub
 
 
 

Private Sub IDTExtensibility2_OnBeginShutdown(custom() As Variant)
 

    'The OnBeginShutdown method is called while the environment is being shut down. The custom parameter is an array

    'that can be used to provide additional data to the OnBeginShutdown method if desired.

    

    If TypeName(mycmdbar) <> "Nothing" Then

        mycmdbar.Delete

    End If

    

    Set mycmdbar = Nothing
 
 

End Sub
 
 
 

Private Sub IDTExtensibility2_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, _

ByVal AddInInst As Object, custom() As Variant)

On Error GoTo Err_IDTExtensibility2_OnConnection
 

    '<INITIAL EVENT THAT FIRES WHEN TEH ADDIN IS LOADED>

    '<SET THE PUBLIC APPLICATION OBJECT TO THE PASSED IN INSTANCE FOR SECURITY AND TRUST>

    'The OnConnection method is called when the add-in is loaded into the environment. The addInInst parameter is an

    'object that represents the instance of the managed COM add-in. The custom parameter is an array that can be used

    'to use to provide additional data to the OnConnection method if desired. The application parameter represents the

    'host application. The connectMode parameter is an ext_cm constant that indicates how the managed COM add-in was loaded.
 

Set out_App = Application
 

Set out_AppInst = AddInInst
 

    '<IF YOU ARE NOT IN STARTUP THEN MANUALLY CALL ONSTARTUPCOMPLETE>
 

If (ConnectMode <> AddInDesignerObjects.ext_ConnectMode.ext_cm_Startup) Then Call IDTExtensibility2_OnStartupComplete(custom)
 

Exit_IDTExtensibility2_OnConnection:

    Exit Sub
 

Err_IDTExtensibility2_OnConnection:

    MsgBox getMessage("errormsg", user_language) & Err.Number & "Outlook IDTExtensibility2_OnConnection", vbCritical, "LuTTool Error"

    Resume Exit_IDTExtensibility2_OnConnection

End Sub
 
 
 

Private Sub IDTExtensibility2_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, _

custom() As Variant)
 
 

'The OnDisconnection method is called when the managed COM add-in is unloaded, such as when the user closes the
 

'host application. The custom parameter is an array that can be used to provide additional data to the OnDisconnection
 

'method if desired. The RemoveMode parameter is an ext_dm constant that indicates how the managed COM add-in was unloaded.
 

If TypeName(mycmdbar) <> "Nothing" Then

    mycmdbar.Delete

End If
 

Set mycmdbar = Nothing
 
 

End Sub
 
 
 

Private Sub IDTExtensibility2_OnStartupComplete(custom() As Variant)

On Error GoTo Err_IDTExtensibility2_OnStartupComplete
 

'<SET OUT TOLBAR BUTTON IN THIS EVENT AS ITS THE LAST TO FIRE SO OUTLOOK WILL BE COMPLETELY LOADED AND STARTED>

'The OnAction property is optional but recommended. It should be set to the ProgID of the add-in, so that if

'the add-in is not loaded when a user clicks the button, MSO loads the add-in automatically and then raises

'the Click event for the add-in to handle.
 
 
 
 

Dim objPicture As stdole.IPictureDisp
 

Dim oPic As StdPicture
 

   Dim oCommandBar As Object

   Dim oButton As Object

   

 ' Load the picture (.bmp file) to use for the button image.

   Set oPic = LoadPicture(App.Path & "\O2LTT2I.bmp") 'add your file here
 
 
 

Set mycmdbar = out_App.ActiveExplorer.CommandBars.Item("Standard").FindControl(, , "890", False, True) 'this example adds a button to the existing command bar

'Set objPicture = LoadPicture(PICTURE_PATH)
 

If TypeName(mycmdbar) = "Nothing" Then

    Set mycmdbar = out_App.ActiveExplorer.CommandBars.Item("Standard").Controls.Add(msoControlButton, , "890", , True)

End If
 

With mycmdbar

    .BeginGroup = True

    .DescriptionText = "XXXXXX"  'No idea when you need this but I put it there

    .Caption = "XXXXXXX"     'This is the text you will see on the command bar

    .Enabled = True

    .OnAction = "!<O2LTT2I.Connect>"

    .Style = msoButtonIconAndCaption

     CopyBitmapAsButtonFace oPic, &HFF00FF

    .PasteFace

    '.Picture = objPicture

    .Tag = "890"

    .ToolTipText = "XXXX" 'This is the text when you hover your mouse over it or when you customize the commandbar

    .Visible = True

End With
 
 

Exit_IDTExtensibility2_OnStartupComplete:

    Exit Sub
 

Err_IDTExtensibility2_OnStartupComplete:

    MsgBox getMessage("errormsg", user_language) & Err.Number & " IDTExtensibility2_OnStartupComplete", vbCritical, "LuTTool Error"

    Resume Exit_IDTExtensibility2_OnStartupComplete

End Sub
 
 
 

Private Sub mycmdbar_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
 

   '<YOUR TOOLBAR BUTTON CLICK EVENT PROCEDURE>
 
 

Put your code here
 
 
 
 

End Sub
 
 
 
 

' ===================================================================

'  CopyBitmapAsButtonFace

'

'  This is the public function to call to create a mask based on the

'  bitmap provided and copy both to the clipboard. The first parameter

'  is a standard VB Picture object. The second should be the color in

'  the image you want to be made transparent.

'

'  Note: This code sample does limited error handling and is designed

'  for VB only (not VBA). You will need to make changes as appropriate

'  to modify the code to suit your needs.

'

' ===================================================================

Public Sub CopyBitmapAsButtonFace(ByVal picSource As StdPicture, _

  ByVal clrMaskColor As OLE_COLOR)

   Dim hPal As Long

   Dim hdcScreen As Long

   Dim hbmButtonFace As Long

   Dim hbmButtonMask As Long

   Dim bDeletePal As Boolean

   Dim lMaskClr As Long

   

 ' Check to make sure we have a valid picture.

   If picSource Is Nothing Then GoTo err_invalidarg

   If picSource.Type <> vbPicTypeBitmap Then GoTo err_invalidarg

   If picSource.Handle = 0 Then GoTo err_invalidarg

   

 ' Get the DC for the display device we are on.

   hdcScreen = GetDC(0)

   hPal = picSource.hPal

   If hPal = 0 Then

      hPal = CreateHalftonePalette(hdcScreen)

      bDeletePal = True

   End If

   

 ' Translate the OLE_COLOR value to a GDI COLORREF value based on the palette.

   OleTranslateColor clrMaskColor, hPal, lMaskClr

      

 ' Create a mask based on the image handed in (hbmButtonMask is the result).

   CreateButtonMask picSource.Handle, lMaskClr, hdcScreen, _

          hPal, hbmButtonMask

         

 ' Let VB copy the bitmap to the clipboard (for the CF_DIB).

   Clipboard.SetData picSource, vbCFDIB
 

 ' Now copy the Button Mask.

   CopyButtonMaskToClipboard hbmButtonMask, hdcScreen

   

 ' Delete the mask and clean up (a copy is on the clipboard).

   DeleteObject hbmButtonMask

   If bDeletePal Then DeleteObject hPal

   ReleaseDC 0, hdcScreen

   

Exit Sub

err_invalidarg:

   Err.Raise 481 'VB Invalid Picture Error

End Sub
 

' ===================================================================

'  CreateButtonMask -- Internal helper function

' ===================================================================

Private Sub CreateButtonMask(ByVal hbmSource As Long, _

  ByVal nMaskColor As Long, ByVal hdcTarget As Long, ByVal hPal As Long, _

  ByRef hbmMask As Long)

   

   Dim hdcSource As Long

   Dim hdcMask As Long

   Dim hbmSourceOld As Long

   Dim hbmMaskOld As Long

   Dim hpalSourceOld As Long

   Dim uBM As BITMAP

   

 ' Get some information about the bitmap handed to us.

   GetObjectAPI hbmSource, 24, uBM

   

 ' Check the size of the bitmap given.

   If uBM.bmWidth < 1 Or uBM.bmWidth > 30000 Then Exit Sub

   If uBM.bmHeight < 1 Or uBM.bmHeight > 30000 Then Exit Sub

 

 ' Create a compatible DC, load the palette and the bitmap.

   hdcSource = CreateCompatibleDC(hdcTarget)

   hpalSourceOld = SelectPalette(hdcSource, hPal, True)

   RealizePalette hdcSource

   hbmSourceOld = SelectObject(hdcSource, hbmSource)
 

 ' Create a black and white mask the same size as the image.

   hbmMask = CreateBitmap(uBM.bmWidth, uBM.bmHeight, 1, 1, ByVal 0)

   

 ' Create a compatble DC for it and load it.

   hdcMask = CreateCompatibleDC(hdcTarget)

   hbmMaskOld = SelectObject(hdcMask, hbmMask)

   

 ' All you need to do is set the mask color as the background color

 ' on the source picture, and set the forground color to white, and

 ' then a simple BitBlt will make the mask for you.

   SetBkColor hdcSource, nMaskColor

   SetTextColor hdcSource, vbWhite

   BitBlt hdcMask, 0, 0, uBM.bmWidth, uBM.bmHeight, hdcSource, _

       0, 0, vbSrcCopy

   

 ' Clean up the memory DCs.

   SelectObject hdcMask, hbmMaskOld

   DeleteDC hdcMask
 

   SelectObject hdcSource, hbmSourceOld

   SelectObject hdcSource, hpalSourceOld

   DeleteDC hdcSource
 

End Sub
 

' ===================================================================

'  CopyButtonMaskToClipboard -- Internal helper function

' ===================================================================

Private Sub CopyButtonMaskToClipboard(ByVal hbmMask As Long, _

  ByVal hdcTarget As Long)

   Dim cfBtnFace As Long

   Dim cfBtnMask As Long

   Dim hGMemFace As Long

   Dim hGMemMask As Long

   Dim lpData As Long

   Dim lpData2 As Long

   Dim hMemTmp As Long

   Dim cbSize As Long

   Dim arrBIHBuffer(50) As Byte

   Dim arrBMDataBuffer() As Byte

   Dim uBIH As BITMAPINFOHEADER

   uBIH.biSize = 40

   

 ' Get the BITMAPHEADERINFO for the mask.

   GetDIBits hdcTarget, hbmMask, 0, 0, ByVal 0&, uBIH, 0

   CopyMemory arrBIHBuffer(0), uBIH, 40
 

 ' Make sure it is a mask image.

   If uBIH.biBitCount <> 1 Then Exit Sub

   If uBIH.biSizeImage < 1 Then Exit Sub

   

 ' Create a temp buffer to hold the bitmap bits.

   ReDim Preserve arrBMDataBuffer(uBIH.biSizeImage + 4) As Byte

   

 ' Open the clipboard.

   If Not CBool(OpenClipboard(0)) Then Exit Sub

   

 ' Get the cf for button face and mask.

   cfBtnFace = RegisterClipboardFormat("Toolbar Button Face")

   cfBtnMask = RegisterClipboardFormat("Toolbar Button Mask")

     

 ' Open DIB on the clipboard and make a copy of it for the button face.

   hMemTmp = GetClipboardData(CF_DIB)

   If hMemTmp <> 0 Then

      cbSize = GlobalSize(hMemTmp)

      hGMemFace = GlobalAlloc(&H2002, cbSize)

      If hGMemFace <> 0 Then

         lpData = GlobalLock(hMemTmp)

         lpData2 = GlobalLock(hGMemFace)

         CopyMemory ByVal lpData2, ByVal lpData, cbSize

         GlobalUnlock hGMemFace

         GlobalUnlock hMemTmp

      

         If SetClipboardData(cfBtnFace, hGMemFace) = 0 Then

            GlobalFree hGMemFace

         End If

         

      End If

   End If

   

 ' Now get the mask bits and the rest of the header.

   GetDIBits hdcTarget, hbmMask, 0, uBIH.biSizeImage, _

        arrBMDataBuffer(0), arrBIHBuffer(0), 0

      

 ' Copy them to global memory and set it on the clipboard.

   hGMemMask = GlobalAlloc(&H2002, uBIH.biSizeImage + 50)

   If hGMemMask <> 0 Then

         lpData = GlobalLock(hGMemMask)

         CopyMemory ByVal lpData, arrBIHBuffer(0), 48

         CopyMemory ByVal (lpData + 48), _

                       arrBMDataBuffer(0), uBIH.biSizeImage

         GlobalUnlock hGMemMask

         

         If SetClipboardData(cfBtnMask, hGMemMask) = 0 Then

            GlobalFree hGMemMask

         End If

         

   End If

   

 ' We're done.

   CloseClipboard

   

End Sub

Open in new window

0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Use these top 10 tips to master the art of email signature design. Create an email signature design that will easily wow recipients, promote your brand and highlight your professionalism.
Sometimes Outlook might have problems sending a message. There may be various causes- corrupted PST, AV scanner etc. The message, instead of going to the Sent Items folder, sits in the Outbox indefinitely. To remove it you can use a free tool cal…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now