Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

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

Posted on 2009-07-03
5
Medium Priority
?
1,563 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
ID: 24771224
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 20

Expert Comment

by:darbid73
ID: 24771383
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
ID: 24771849
Yes I have administrative rights on the computers so distributing and registering a .dll will not be a problem.
0
 

Author Comment

by:MrBabbage
ID: 24771859
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 20

Accepted Solution

by:
darbid73 earned 2000 total points
ID: 24772232
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

Fill in the form and get your FREE NFR key NOW!

Veeam is happy to provide a FREE NFR server license to certified engineers, trainers, and bloggers.  It allows for the non‑production use of Veeam Agent for Microsoft Windows. This license is valid for five workstations and two servers.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will help to fix the below errors for MS Exchange Server 2013 I. Certificate error "name on the security certificate is invalid or does not match the name of the site" II. Out of Office not working III. Make Internal URLs and Externa…
There can be many situations demanding the conversion of Outlook OST files to PST format and as such, there is no shortage of automated tools to perform this conversion. However, what makes Stellar OST to PST converter stand above the rest? Let us e…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
There are cases when e.g. an IT administrator wants to have full access and view into selected mailboxes on Exchange server, directly from his own email account in Outlook or Outlook Web Access. This proves useful when for example administrator want…

963 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