实在是看不懂VB的这些东东，有谁熟悉的帮帮忙吧！' ===================================================================
' 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, hdcScreenExit 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 hdcSourceEnd 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.
CloseClipboardEnd Sub
代码来自：
http://support.microsoft.com/kb/288771/zh-cn
谢谢了，如果翻译成VC也行！测试通过后给分！
' 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, hdcScreenExit 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 hdcSourceEnd 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.
CloseClipboardEnd Sub
代码来自：
http://support.microsoft.com/kb/288771/zh-cn
谢谢了，如果翻译成VC也行！测试通过后给分！
Delphi里的声明是
function GetDIBits(DC: HDC; Bitmap: HBITMAP; StartScan: Cardinal; NumScans: Cardinal; Bits: Pointer; var BitInfo: tagBITMAPINFO; Usage: Cardinal): IntegerGetDIBits hdcTarget, hbmMask, 0, 0, ByVal 0&, uBIH, 0
你可以试试这样调用：
GetDIBits hdcTarget, hbmMask, 0, 0, nil, uBIH, 0
如果 hdcTarget、hbmMask、uBIH 都定义了的话。
而只是tagBitmapHEADINFO