Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private 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 Public Function BmpToBmp() As Picture Dim Y As Integer, XX As Long, YY As Long, R&, G&, B& Dim PicAry() As Byte Dim W As Long, H As Long With ImageList1.ListImages(1) W = .Picture.Width / 15 H = .Picture.Height / 15
ReDim PicAry(W * 3 - 1, H - 1) As Byte
Call GetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0)) For YY = 0 To H - 1 Step 1 For XX = 0 To W - 1 Step 1 R = PicAry(XX * 3 + 2, YY): G = PicAry(XX * 3 + 1, YY): B = PicAry(XX * 3, YY) Y = (299 * R + 587 * G + 114 * B) / 1000 PicAry(XX * 3 + 2, YY) = Y: PicAry(XX * 3 + 1, YY) = Y: PicAry(XX * 3, YY) = Y Next XX Next YY Call SetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0)) Set BmpToBmp = .Picture End With End Function
是可以的 Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private 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 Public Function BmpToBmp() As Picture Dim Y As Integer, XX As Long, YY As Long, R&, G&, B& Dim PicAry() As Byte Dim W As Long, H As Long With ImageList1.ListImages(1) W = .Picture.Width / 15 H = .Picture.Height / 15
ReDim PicAry(W * 3 - 1, H - 1) As Byte
Call GetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0)) For YY = 0 To H - 1 Step 1 For XX = 0 To W - 1 Step 1 R = PicAry(XX * 3 + 2, YY): G = PicAry(XX * 3 + 1, YY): B = PicAry(XX * 3, YY) Y = (299 * R + 587 * G + 114 * B) / 1000 PicAry(XX * 3 + 2, YY) = Y: PicAry(XX * 3 + 1, YY) = Y: PicAry(XX * 3, YY) = Y Next XX Next YY Call SetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0)) Set BmpToBmp = .Picture End With End FunctionPrivate Sub Form_Load() Picture1.AutoRedraw = True Picture1.PaintPicture BmpToBmp, 0, 0, Picture1.Width, Picture1.Height, 0, 0 End Sub
我刚调试过没有问题啊!调用: Set Picture1.Picture=BmpToBmp
我知道了,我的ImageList加的是icon,所以上面的代码才不起作用
图片是ICON或Gif格式不可以,以上只能转换位图
我的ImageList加载的主要是icon图标
以下可以处理各种格式图片: Public Sub BmpGray(ByVal Pic As PictureBox) Dim PicBits() As Byte, PicInfo As BITMAP, BytesPerPixel As Long Dim R As Byte, G As Byte, B As Byte, Gray As Byte, i As Long With Pic .AutoRedraw = True GetObject .Image, Len(PicInfo), PicInfo BytesPerPixel = PicInfo.bmBitsPixel \ 8 ReDim PicBits(1 To PicInfo.bmWidth * PicInfo.bmHeight * BytesPerPixel) GetBitmapBits .Image, UBound(PicBits), PicBits(1) For i = 0 To UBound(PicBits) \ BytesPerPixel - 1 B = PicBits(i * BytesPerPixel + 1) G = PicBits(i * BytesPerPixel + 2) R = PicBits(i * BytesPerPixel + 3) Gray = R * 0.39 + G * 0.5 + B * 0.11 '下面这一句是将灰度值换算成二值 ' If Gray > 127 Then Gray = 255 Else Gray = 0 PicBits(i * BytesPerPixel + 1) = Gray PicBits(i * BytesPerPixel + 2) = Gray PicBits(i * BytesPerPixel + 3) = Gray Next i SetBitmapBits .Image, UBound(PicBits), PicBits(1) .Refresh End With End Sub
请各位帮我看看下面的代码错在那? 画出来的是一个黑色方块,并不是原来的图形了Option ExplicitPrivate Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) 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 DeleteDC Lib "gdi32" (ByVal hdc 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 Const ILD_TRANSPARENT As Long = &H1 Private Sub Command1_Click()
Dim lngWidth As Long Dim lngHeight As Long Dim hMemDC As Long Dim hDesDC As Long Dim hMemBMP As Long Dim hOldBMP As Long
没必要非要先变灰再draw啊 以上改为: Private Sub Command1_Click() Dim lngWidth As Long Dim lngHeight As Long Dim hMemDC As Long Dim hDesDC As Long Dim hMemBMP As Long Dim hOldBMP As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private 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
Public Function BmpToBmp() As Picture
Dim Y As Integer, XX As Long, YY As Long, R&, G&, B&
Dim PicAry() As Byte
Dim W As Long, H As Long With ImageList1.ListImages(1)
W = .Picture.Width / 15
H = .Picture.Height / 15
ReDim PicAry(W * 3 - 1, H - 1) As Byte
Call GetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0))
For YY = 0 To H - 1 Step 1
For XX = 0 To W - 1 Step 1
R = PicAry(XX * 3 + 2, YY): G = PicAry(XX * 3 + 1, YY): B = PicAry(XX * 3, YY)
Y = (299 * R + 587 * G + 114 * B) / 1000
PicAry(XX * 3 + 2, YY) = Y: PicAry(XX * 3 + 1, YY) = Y: PicAry(XX * 3, YY) = Y
Next XX
Next YY
Call SetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0))
Set BmpToBmp = .Picture
End With
End Function
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private 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
Public Function BmpToBmp() As Picture
Dim Y As Integer, XX As Long, YY As Long, R&, G&, B&
Dim PicAry() As Byte
Dim W As Long, H As Long With ImageList1.ListImages(1)
W = .Picture.Width / 15
H = .Picture.Height / 15
ReDim PicAry(W * 3 - 1, H - 1) As Byte
Call GetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0))
For YY = 0 To H - 1 Step 1
For XX = 0 To W - 1 Step 1
R = PicAry(XX * 3 + 2, YY): G = PicAry(XX * 3 + 1, YY): B = PicAry(XX * 3, YY)
Y = (299 * R + 587 * G + 114 * B) / 1000
PicAry(XX * 3 + 2, YY) = Y: PicAry(XX * 3 + 1, YY) = Y: PicAry(XX * 3, YY) = Y
Next XX
Next YY
Call SetBitmapBits(.Picture.Handle, W * 3 * H - 1, PicAry(0, 0))
Set BmpToBmp = .Picture
End With
End FunctionPrivate Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.PaintPicture BmpToBmp, 0, 0, Picture1.Width, Picture1.Height, 0, 0
End Sub
Set Picture1.Picture=BmpToBmp
Public Sub BmpGray(ByVal Pic As PictureBox)
Dim PicBits() As Byte, PicInfo As BITMAP, BytesPerPixel As Long
Dim R As Byte, G As Byte, B As Byte, Gray As Byte, i As Long
With Pic
.AutoRedraw = True
GetObject .Image, Len(PicInfo), PicInfo
BytesPerPixel = PicInfo.bmBitsPixel \ 8
ReDim PicBits(1 To PicInfo.bmWidth * PicInfo.bmHeight * BytesPerPixel)
GetBitmapBits .Image, UBound(PicBits), PicBits(1)
For i = 0 To UBound(PicBits) \ BytesPerPixel - 1
B = PicBits(i * BytesPerPixel + 1)
G = PicBits(i * BytesPerPixel + 2)
R = PicBits(i * BytesPerPixel + 3)
Gray = R * 0.39 + G * 0.5 + B * 0.11
'下面这一句是将灰度值换算成二值
' If Gray > 127 Then Gray = 255 Else Gray = 0
PicBits(i * BytesPerPixel + 1) = Gray
PicBits(i * BytesPerPixel + 2) = Gray
PicBits(i * BytesPerPixel + 3) = Gray
Next i
SetBitmapBits .Image, UBound(PicBits), PicBits(1)
.Refresh
End With
End Sub
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) 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 DeleteDC Lib "gdi32" (ByVal hdc 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 Const ILD_TRANSPARENT As Long = &H1
Private Sub Command1_Click()
Dim lngWidth As Long
Dim lngHeight As Long
Dim hMemDC As Long
Dim hDesDC As Long
Dim hMemBMP As Long
Dim hOldBMP As Long
lngWidth = ImageList1.ImageWidth
lngHeight = ImageList1.ImageHeight
hDesDC = Picture1.hdc
hMemDC = CreateCompatibleDC(hDesDC)
hMemBMP = CreateCompatibleBitmap(hMemDC, lngWidth, lngHeight)
hOldBMP = SelectObject(hMemDC, hMemBMP)
ImageList1.ListImages(1).Draw hMemDC, 0, 0, ILD_TRANSPARENT
BitBlt hDesDC, 0, 0, lngWidth, lngHeight, hMemDC, 0, 0, vbSrcCopy
SelectObject hMemDC, hOldBMP
DeleteObject hMemBMP
DeleteDC hMemDC
End Sub
以上改为:
Private Sub Command1_Click()
Dim lngWidth As Long
Dim lngHeight As Long
Dim hMemDC As Long
Dim hDesDC As Long
Dim hMemBMP As Long
Dim hOldBMP As Long
lngWidth = ImageList1.ImageWidth
lngHeight = ImageList1.ImageHeight
hDesDC = Picture1.hdc
hMemDC = CreateCompatibleDC(hDesDC)
hMemBMP = CreateCompatibleBitmap(hMemDC, lngWidth, lngHeight)
hOldBMP = SelectObject(hMemDC, hMemBMP)
ImageList1.ListImages(1).Draw hMemDC, 0, 0
BitBlt hDesDC, 0, 0, lngWidth, lngHeight, hMemDC, 0, 0, vbSrcCopy
SelectObject hMemDC, hOldBMP
DeleteObject hMemBMP
DeleteDC hMemDC
End Sub
帮你找一个:
http://www.samlong.cn/soft/67/77/222/2007/20070110102085.html
改为
hMemBMP = CreateCompatibleBitmap(hDesDC, lngWidth, lngHeight)
就不再是黑块了。
不过,由于hMemBmp默认的背景是黑色,而你又使用ImageList1.ListImages(1).Draw hMemDC, 0, 0, ILD_TRANSPARENT进行透明绘制,结果使用BitBlt后将出现黑色的背景。
解决办法:
一、让ImageList1直接在Picturebox上透明绘制。
二、或者,将hMemBmp的背景填充为PictureBox的背景。
三、或者,使用TransparentBlt而不是BitBlt。
fuFlags参数设为DSS_DISABLED或DSS_MONO(需指定画刷)。
图标是由两个位图组成的,楼主需要把其中叫做IMAGE的那个位图灰化。
灰化需要用到DIB段以提高速度。
之后的数据,如果想借助于绘制ICON的API,还要用CreateIconIndirect等再重建为ICON,要不这些函数才不知道你的那些数据是什么呢。当然也可以直接使用,直接当BMP来绘制,需要多次调用BitBlt,配合适当的RO2操作,使那两个位图“IMAGE”和“MASK”形成一个透明的效果(就是图标效果)。