
常用软件类: |
|杀毒安全 | |联络聊天 | |网络软件 | |多媒体类 | |系统工具 | |图形图像 | |系统工具 | |应用软件 | |行业软件 |
开发设计类: |
|动画制作 | |图像处理 | |3D设计 | |操作系统 | |站长学院 | |网络相关 | |WEB设计 | |数据库类 | |程序开发 |
| 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 LongDim 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 - TimeGetExit 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.bmiHeader, 0 Done = True TimePut = timeGetTime - TimePut Exit Sub ErrLine: MsgBox Err.Description End Sub |
下面解释一下在过程中到的全局变量和数据结构,以及API的定义。
API定义:
删除一个DC
| 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 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 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 bi24BitInfo As BitMapInfo '定义BMP信息 |
| 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 |
| Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long) |
| 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 |