可以帮忙看下我的 GETDIBITS ,SETDIBITS CODE 出现什么问题吗?
Option ExplicitPrivate Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType 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 BitMapInfo, ByVal wUsage As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BitMapInfo, ByVal wUsage As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Private Type BitMapInfoHeader 'ÎļþÐÅϢͷ--BITMAPINFOHEADER
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
Private Type RGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
'rgbReserved As Byte
End Type
Private Type BitMapInfo
bmiHeader As BitMapInfoHeader
bmiColors As RGBQuad
End Type
Private Const Bits As Long = 32 'ÑÕÉ«Éî¶È£¬ÕâÀï°ÑËùÓÐͼÏñ¶¼°´ÕÕ32λÀ´´¦Àí
Public Done As Boolean 'ÓÃÓÚ±ê¼ÇÒ»¸ö¹ý³ÌÊÇ·ñ½áÊø
Public TimeGet As Long 'ÓÃÓڼǼÊäÈë¹ý³Ì´¦ÀíËù»¨·ÑµÄʱ¼ä
Public TimePut As Long 'ÓÃÓڼǼÊä³ö¹ý³Ì´¦ÀíËù»¨·ÑµÄʱ¼ä
Dim ColVal() As Byte 'ÓÃÓÚ´æ·Å´ÓDIBÊäÈëµÄÏñËØÖµ
Dim ColOut() As Byte 'ÓÃÓÚ´æ·ÅÏòDIBÊä³öµÄÏñËØÖµ
Dim InPutHei As Long 'ÓÃÓڼǼÊäÈëͼÏñµÄ¸ß¶È
Dim InPutWid As Long 'ÓÃÓڼǼÊäÈëͼÏñµÄ¿í¶È
Dim OutputWid As Long
Dim OutputHei As Long
Dim LineBytes As Long
Dim bi24BitInfo As BitMapInfo '¶¨ÒåBMPÐÅÏ¢
Public Sub DibGet(ByVal IdSource As Long, XBegin As Long, ByVal YBegin As Long, ByVal XEnd As Long, ByVal YEnd As Long)
Dim iBitmap As Long
Dim iDC As Long
Dim I As Long
Dim W As Long
Dim H As Long
On Error GoTo ErrLine
Done = False
TimeGet = timeGetTime
InPutWid = XEnd - XBegin
InPutHei = YEnd - YBegin
W = InPutWid + 1
H = InPutHei + 1
I = (Bits \ 8) - 1
ReDim ColVal(I, InPutWid, InPutHei)
With bi24BitInfo.bmiHeader
.biBitCount = Bits
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = W
.biHeight = H
End With
iBitmap = GetCurrentObject(IdSource, 7&)
GetDIBits IdSource, iBitmap, 0&, H, ColVal(0, 0, 0), bi24BitInfo, 0&
DeleteObject iBitmap
Done = True
TimeGet = timeGetTime - TimeGet
Exit Sub
ErrLine:
MsgBox "´íÎóºÅ£º" & Err.Number & "£º" & Err.Description
End Sub
Public Sub DIBPut(ByVal IdDestination As Long)
Dim W As Long
Dim H As Long
On Error GoTo ErrLine
Done = False
TimePut = timeGetTime
W = OutputWid + 1
H = OutputHei + 1
With bi24BitInfo.bmiHeader
.biWidth = W
.biHeight = H
LineBytes = ((W * Bits + 31) And &HFFFFFFE0) \ 8
.biSizeImage = LineBytes * H
End With
SetDIBitsToDevice IdDestination, 0, 0, W, H, 0, 0, 0, H, ColOut(0, 0, 0), bi24BitInfo, 0&
Done = True
TimePut = timeGetTime - TimePut
Exit Sub
ErrLine:
MsgBox Err.Description
End Sub
Public Sub CopyData(ByVal W As Long, ByVal H As Long)
Dim Length As Long
Dim I As Long
Dim L As Long
I = Bits \ 8
L = I - 1
Length = (W + 1&) * (H + 1&) * I
ReDim ColOut(L, W, H)
CopyMemory ColOut(0, 0, 0), ColVal(0, 0, 0), Length
End Sub
Sub Command1_Click()
With Picture1
.ScaleMode = 3
.BorderStyle = 0
DibGet .hdc, 0, 0, .ScaleWidth, .ScaleHeight
End With
CopyData InPutHei, InPutWid
Picture2.AutoRedraw = True
DIBPut Picture2.hdc
Picture2.Refresh
End Sub
图片没有显现在PictureBox2 里,这是VB6....感谢不尽了
[[it] 本帖最后由 summer_mun 于 2008-11-29 12:23 编辑 [/it]]