home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Add_In_for1979733122006.psc / Addin_code.bas < prev    next >
BASIC Source File  |  2006-03-12  |  12KB  |  323 lines
  1. Attribute VB_Name = "Addin_code"
  2. Option Explicit
  3. '
  4.  
  5. 'see this sample project.
  6. 'C:\Program Files\Microsoft Visual Studio\MSDN98\98VSa\1033\SAMPLES\VB98\Taborder
  7.  
  8.  
  9. Public gButtonVisibleIndex As Long
  10. Public gCountControlButtons As Long
  11.  
  12. Public gVBE As VBIDE.VBE
  13. Public gWindow  As VBIDE.Window    'used to make sure we only run one instance
  14. 'Public gEvents As Events
  15. 'public gDocWindow As Object          'user doc object
  16.  
  17. Public mcbMenuCommandBar As Office.CommandBarControl
  18.  
  19. 'gobj_events.
  20.  
  21.  
  22. '//////////////////////////////////////////////////////////
  23. ' How to copy a 'transparent' image to an office button.
  24. ' http://support.microsoft.com/kb/288771/en-us
  25. '//////////////////////////////////////////////////////////
  26. ' Everything below this line is probably copyrighted by Microsoft
  27. ' However, this code is openly avaiable through the online MSDN
  28. '////////////////////////////////////////////////
  29.  
  30. Public Type BITMAPINFOHEADER '40 bytes
  31.    biSize As Long
  32.    biWidth As Long
  33.    biHeight As Long
  34.    biPlanes As Integer
  35.    biBitCount As Integer
  36.    biCompression As Long
  37.    biSizeImage As Long
  38.    biXPelsPerMeter As Long
  39.    biYPelsPerMeter As Long
  40.    biClrUsed As Long
  41.    biClrImportant As Long
  42. End Type
  43.  
  44. Public Type BITMAP
  45.    bmType As Long
  46.    bmWidth As Long
  47.    bmHeight As Long
  48.    bmWidthBytes As Long
  49.    bmPlanes As Integer
  50.    bmBitsPixel As Integer
  51.    bmBits As Long
  52. End Type
  53.  
  54. ' ===================================================================
  55. '   GDI/Drawing Functions (to build the mask)
  56. ' ===================================================================
  57. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  58. Private Declare Function ReleaseDC Lib "user32" _
  59.   (ByVal hwnd As Long, ByVal hdc As Long) As Long
  60. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  61. Private Declare Function CreateCompatibleDC Lib "gdi32" _
  62.   (ByVal hdc As Long) As Long
  63. Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
  64.   (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  65. Private Declare Function CreateBitmap Lib "gdi32" _
  66.   (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, _
  67.    ByVal nBitCount As Long, lpBits As Any) As Long
  68. Private Declare Function SelectObject Lib "gdi32" _
  69.   (ByVal hdc As Long, ByVal hObject As Long) As Long
  70. Private Declare Function DeleteObject Lib "gdi32" _
  71.   (ByVal hObject As Long) As Long
  72. Private Declare Function GetBkColor Lib "gdi32" _
  73.   (ByVal hdc As Long) As Long
  74. Private Declare Function SetBkColor Lib "gdi32" _
  75.   (ByVal hdc As Long, ByVal crColor As Long) As Long
  76. Private Declare Function GetTextColor Lib "gdi32" _
  77.   (ByVal hdc As Long) As Long
  78. Private Declare Function SetTextColor Lib "gdi32" _
  79.   (ByVal hdc As Long, ByVal crColor As Long) As Long
  80. Private Declare Function BitBlt Lib "gdi32" _
  81.   (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
  82.    ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
  83.    ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  84. Private Declare Function CreateHalftonePalette Lib "gdi32" _
  85.   (ByVal hdc As Long) As Long
  86. Private Declare Function SelectPalette Lib "gdi32" _
  87.   (ByVal hdc As Long, ByVal hPalette As Long, _
  88.    ByVal bForceBackground As Long) As Long
  89. Private Declare Function RealizePalette Lib "gdi32" _
  90.   (ByVal hdc As Long) As Long
  91. Private Declare Function OleTranslateColor Lib "oleaut32.dll" _
  92.   (ByVal lOleColor As Long, ByVal lHPalette As Long, _
  93.    lColorRef As Long) As Long
  94. Private Declare Function GetDIBits Lib "gdi32" _
  95.   (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
  96.    ByVal nNumScans As Long, lpBits As Any, lpBI As Any, _
  97.    ByVal wUsage As Long) As Long
  98. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
  99.   (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  100.  
  101. ' ===================================================================
  102. '   Clipboard APIs
  103. ' ===================================================================
  104. Private Declare Function OpenClipboard Lib "user32" _
  105.   (ByVal hwnd As Long) As Long
  106. Private Declare Function CloseClipboard Lib "user32" () As Long
  107. Private Declare Function RegisterClipboardFormat Lib "user32" _
  108.   Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
  109. Private Declare Function GetClipboardData Lib "user32" _
  110.   (ByVal wFormat As Long) As Long
  111. Private Declare Function SetClipboardData Lib "user32" _
  112.   (ByVal wFormat As Long, ByVal hMem As Long) As Long
  113. Private Declare Function EmptyClipboard Lib "user32" () As Long
  114. Private Const CF_DIB = 8
  115.  
  116. ' ===================================================================
  117. '   Memory APIs (for clipboard transfers)
  118. ' ===================================================================
  119. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  120.   (pDest As Any, pSource As Any, ByVal cbLength As Long)
  121. Private Declare Function GlobalAlloc Lib "kernel32" _
  122.   (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  123. Private Declare Function GlobalFree Lib "kernel32" _
  124.   (ByVal hMem As Long) As Long
  125. Private Declare Function GlobalLock Lib "kernel32" _
  126.   (ByVal hMem As Long) As Long
  127. Private Declare Function GlobalSize Lib "kernel32" _
  128.   (ByVal hMem As Long) As Long
  129. Private Declare Function GlobalUnlock Lib "kernel32" _
  130.   (ByVal hMem As Long) As Long
  131. Private Const GMEM_DDESHARE = &H2000
  132. Private Const GMEM_MOVEABLE = &H2
  133.  
  134. ' ===================================================================
  135. '  CopyBitmapAsButtonFace
  136. '
  137. '  This is the public function to call to create a mask based on the
  138. '  bitmap provided and copy both to the clipboard. The first parameter
  139. '  is a standard VB Picture object. The second should be the color in
  140. '  the image you want to be made transparent.
  141. '
  142. '  Note: This code sample does limited error handling and is designed
  143. '  for VB only (not VBA). You will need to make changes as appropriate
  144. '  to modify the code to suit your needs.
  145. '
  146. ' ===================================================================
  147. Public Sub CopyBitmapAsButtonFace(ByVal picSource As StdPicture, _
  148.   ByVal clrMaskColor As OLE_COLOR)
  149.    Dim hPal As Long
  150.    Dim hdcScreen As Long
  151.    Dim hbmButtonFace As Long
  152.    Dim hbmButtonMask As Long
  153.    Dim bDeletePal As Boolean
  154.    Dim lMaskClr As Long
  155.  
  156.  ' Check to make sure we have a valid picture.
  157.    If picSource Is Nothing Then GoTo err_invalidarg
  158.    If picSource.Type <> vbPicTypeBitmap Then GoTo err_invalidarg
  159.    If picSource.Handle = 0 Then GoTo err_invalidarg
  160.  
  161.  ' Get the DC for the display device we are on.
  162.    hdcScreen = GetDC(0)
  163.    hPal = picSource.hPal
  164.    If hPal = 0 Then
  165.       hPal = CreateHalftonePalette(hdcScreen)
  166.       bDeletePal = True
  167.    End If
  168.  
  169.  ' Translate the OLE_COLOR value to a GDI COLORREF value based on the palette.
  170.    OleTranslateColor clrMaskColor, hPal, lMaskClr
  171.  
  172.  ' Create a mask based on the image handed in (hbmButtonMask is the result).
  173.    CreateButtonMask picSource.Handle, lMaskClr, hdcScreen, _
  174.           hPal, hbmButtonMask
  175.  
  176.  ' Let VB copy the bitmap to the clipboard (for the CF_DIB).
  177.    Clipboard.SetData picSource, vbCFDIB
  178.  
  179.  ' Now copy the Button Mask.
  180.    CopyButtonMaskToClipboard hbmButtonMask, hdcScreen
  181.  
  182.  ' Delete the mask and clean up (a copy is on the clipboard).
  183.    DeleteObject hbmButtonMask
  184.    If bDeletePal Then DeleteObject hPal
  185.    ReleaseDC 0, hdcScreen
  186.  
  187. Exit Sub
  188. err_invalidarg:
  189.    Err.Raise 481 'VB Invalid Picture Error
  190. End Sub
  191.  
  192. ' ===================================================================
  193. '  CreateButtonMask -- Internal helper function
  194. ' ===================================================================
  195. Private Sub CreateButtonMask(ByVal hbmSource As Long, _
  196.   ByVal nMaskColor As Long, ByVal hdcTarget As Long, ByVal hPal As Long, _
  197.   ByRef hbmMask As Long)
  198.  
  199.    Dim hdcSource As Long
  200.    Dim hdcMask As Long
  201.    Dim hbmSourceOld As Long
  202.    Dim hbmMaskOld As Long
  203.    Dim hpalSourceOld As Long
  204.    Dim uBM As BITMAP
  205.  
  206.  ' Get some information about the bitmap handed to us.
  207.    GetObjectAPI hbmSource, 24, uBM
  208.  
  209.  ' Check the size of the bitmap given.
  210.    If uBM.bmWidth < 1 Or uBM.bmWidth > 30000 Then Exit Sub
  211.    If uBM.bmHeight < 1 Or uBM.bmHeight > 30000 Then Exit Sub
  212.  
  213.  ' Create a compatible DC, load the palette and the bitmap.
  214.    hdcSource = CreateCompatibleDC(hdcTarget)
  215.    hpalSourceOld = SelectPalette(hdcSource, hPal, True)
  216.    RealizePalette hdcSource
  217.    hbmSourceOld = SelectObject(hdcSource, hbmSource)
  218.  
  219.  ' Create a black and white mask the same size as the image.
  220.    hbmMask = CreateBitmap(uBM.bmWidth, uBM.bmHeight, 1, 1, ByVal 0)
  221.  
  222.  ' Create a compatble DC for it and load it.
  223.    hdcMask = CreateCompatibleDC(hdcTarget)
  224.    hbmMaskOld = SelectObject(hdcMask, hbmMask)
  225.  
  226.  ' All you need to do is set the mask color as the background color
  227.  ' on the source picture, and set the forground color to white, and
  228.  ' then a simple BitBlt will make the mask for you.
  229.    SetBkColor hdcSource, nMaskColor
  230.    SetTextColor hdcSource, vbWhite
  231.    BitBlt hdcMask, 0, 0, uBM.bmWidth, uBM.bmHeight, hdcSource, _
  232.        0, 0, vbSrcCopy
  233.  
  234.  ' Clean up the memory DCs.
  235.    SelectObject hdcMask, hbmMaskOld
  236.    DeleteDC hdcMask
  237.  
  238.    SelectObject hdcSource, hbmSourceOld
  239.    SelectObject hdcSource, hpalSourceOld
  240.    DeleteDC hdcSource
  241.  
  242. End Sub
  243.  
  244. ' ===================================================================
  245. '  CopyButtonMaskToClipboard -- Internal helper function
  246. ' ===================================================================
  247. Private Sub CopyButtonMaskToClipboard(ByVal hbmMask As Long, _
  248.   ByVal hdcTarget As Long)
  249.    Dim cfBtnFace As Long
  250.    Dim cfBtnMask As Long
  251.    Dim hGMemFace As Long
  252.    Dim hGMemMask As Long
  253.    Dim lpData As Long
  254.    Dim lpData2 As Long
  255.    Dim hMemTmp As Long
  256.    Dim cbSize As Long
  257.    Dim arrBIHBuffer(50) As Byte
  258.    Dim arrBMDataBuffer() As Byte
  259.    Dim uBIH As BITMAPINFOHEADER
  260.    uBIH.biSize = 40
  261.  
  262.  ' Get the BITMAPHEADERINFO for the mask.
  263.    GetDIBits hdcTarget, hbmMask, 0, 0, ByVal 0&, uBIH, 0
  264.    CopyMemory arrBIHBuffer(0), uBIH, 40
  265.  
  266.  ' Make sure it is a mask image.
  267.    If uBIH.biBitCount <> 1 Then Exit Sub
  268.    If uBIH.biSizeImage < 1 Then Exit Sub
  269.  
  270.  ' Create a temp buffer to hold the bitmap bits.
  271.    ReDim Preserve arrBMDataBuffer(uBIH.biSizeImage + 4) As Byte
  272.  
  273.  ' Open the clipboard.
  274.    If Not CBool(OpenClipboard(0)) Then Exit Sub
  275.  
  276.  ' Get the cf for button face and mask.
  277.    cfBtnFace = RegisterClipboardFormat("Toolbar Button Face")
  278.    cfBtnMask = RegisterClipboardFormat("Toolbar Button Mask")
  279.  
  280.  ' Open DIB on the clipboard and make a copy of it for the button face.
  281.    hMemTmp = GetClipboardData(CF_DIB)
  282.    If hMemTmp <> 0 Then
  283.       cbSize = GlobalSize(hMemTmp)
  284.       hGMemFace = GlobalAlloc(&H2002, cbSize)
  285.       If hGMemFace <> 0 Then
  286.          lpData = GlobalLock(hMemTmp)
  287.          lpData2 = GlobalLock(hGMemFace)
  288.          CopyMemory ByVal lpData2, ByVal lpData, cbSize
  289.          GlobalUnlock hGMemFace
  290.          GlobalUnlock hMemTmp
  291.  
  292.          If SetClipboardData(cfBtnFace, hGMemFace) = 0 Then
  293.             GlobalFree hGMemFace
  294.          End If
  295.  
  296.       End If
  297.    End If
  298.  
  299.  ' Now get the mask bits and the rest of the header.
  300.    GetDIBits hdcTarget, hbmMask, 0, uBIH.biSizeImage, _
  301.         arrBMDataBuffer(0), arrBIHBuffer(0), 0
  302.  
  303.  ' Copy them to global memory and set it on the clipboard.
  304.    hGMemMask = GlobalAlloc(&H2002, uBIH.biSizeImage + 50)
  305.    If hGMemMask <> 0 Then
  306.          lpData = GlobalLock(hGMemMask)
  307.          CopyMemory ByVal lpData, arrBIHBuffer(0), 48
  308.          CopyMemory ByVal (lpData + 48), _
  309.                        arrBMDataBuffer(0), uBIH.biSizeImage
  310.          GlobalUnlock hGMemMask
  311.  
  312.          If SetClipboardData(cfBtnMask, hGMemMask) = 0 Then
  313.             GlobalFree hGMemMask
  314.          End If
  315.  
  316.    End If
  317.  
  318.  ' We're done.
  319.    CloseClipboard
  320.  
  321. End Sub
  322.  
  323.