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 to this this is the event when you click this button
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
