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 bi24BitInfo As BitMapInfo '定义BMP信息
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 TypePrivate Type RGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End TypePrivate Type BitMapInfo
bmiHeader As BitMapInfoHeader
bmiColors As RGBQuad
End Type
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 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 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 timeGetTime Lib "winmm.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)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
Public Sub DIBPut(ByVal IdDestination As Long)
Dim W As Long
Dim H As LongOn Error GoTo ErrLine
Done = False
TimePut = timeGetTimeW = OutPutWid + 1
H = OutPutHei + 1With 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, 0Done = True
TimePut = timeGetTime - TimePut
Exit Sub
ErrLine:
MsgBox Err.Description
End Sub
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 LongOn Error GoTo ErrLine
Done = False
TimeGet = timeGetTime
InPutWid = XEnd - XBegin
InPutHei = YEnd - YBegin
W = InPutWid + 1
H = InPutHei + 1I = (Bits \ 8) - 1
ReDim ColVal(I, InPutWid, InPutHei)
With bi24BitInfo.bmiHeader
BitMapInfoHeader = Bits
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = W
.biHeight = H
End WithiBitmap = 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
Private 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
Private Sub Form_Load()
Picture1.Picture = LoadPicture("D:\Program Files\SuperSoft\RdfSnap\屏幕截图\000.bmp")
End Sub
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 bi24BitInfo As BitMapInfo '定义BMP信息
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 TypePrivate Type RGBQuad
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End TypePrivate Type BitMapInfo
bmiHeader As BitMapInfoHeader
bmiColors As RGBQuad
End Type
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 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 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 timeGetTime Lib "winmm.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)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
Public Sub DIBPut(ByVal IdDestination As Long)
Dim W As Long
Dim H As LongOn Error GoTo ErrLine
Done = False
TimePut = timeGetTimeW = OutPutWid + 1
H = OutPutHei + 1With 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, 0Done = True
TimePut = timeGetTime - TimePut
Exit Sub
ErrLine:
MsgBox Err.Description
End Sub
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 LongOn Error GoTo ErrLine
Done = False
TimeGet = timeGetTime
InPutWid = XEnd - XBegin
InPutHei = YEnd - YBegin
W = InPutWid + 1
H = InPutHei + 1I = (Bits \ 8) - 1
ReDim ColVal(I, InPutWid, InPutHei)
With bi24BitInfo.bmiHeader
BitMapInfoHeader = Bits
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = W
.biHeight = H
End WithiBitmap = 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
Private 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
Private Sub Form_Load()
Picture1.Picture = LoadPicture("D:\Program Files\SuperSoft\RdfSnap\屏幕截图\000.bmp")
End Sub
BitMapInfoHeader是定义的文件信息头类型,而在DibGet函数怎么会有这种用法:BitMapInfoHeader=Bits ???
'本程序演示将BMP位图文件显示在picture1中,并将picture1保存到一维数组中,再将一维数组还原成图像到picture2中
'在Form1上添加2个图片框picture1、picture2,1个命令按钮command1
'事先在picture1中装入一张JPG图片,picture2.width=picture1.width,然后picture2.height=picture1.height
Option ExplicitPrivate Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
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 LongPrivate 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
Dim PictureBits() As Byte, PictureInfo As BITMAP, iBit As LongPrivate Sub Form_Load()
Picture1.Picture = LoadPicture("D:\Program Files\SuperSoft\RdfSnap\屏幕截图\000.bmp")
Picture2.Width = Picture1.Width
Picture2.Height = Picture1.Height
End SubPrivate Sub Command1_Click()
GetObject Picture1.Image, Len(PictureInfo), PictureInfo
ReDim PictureBits(1 To PictureInfo.bmWidthBytes * PictureInfo.bmHeight) As Byte
GetBitmapBits Picture1.Image, UBound(PictureBits), PictureBits(1)
SetBitmapBits Picture2.Image, UBound(PictureBits), PictureBits(1) '将数组还原成图像
Picture2.Refresh
End Sub