'http://www.ooppoo.com/html/33/n-30533.html
Option Explicit
'类模块:
Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Private Type 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 Bitmap
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
BmBits As Long
End Type
Private Const DIB_RGB_COLORS As Long = 0
Private Const OBJ_BITMAP As Long = 7
Private Const SRCCOPY As Long = &HCC0020
Private Const COLORONCOLOR As Long = 3
Private Const CF_BITMAP As Long = 2
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj 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 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 Declare Function VarPtrArray Lib "msvbvm50" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private mBmpInfoHeader As BITMAPINFOHEADER
Private mhDC As Long
Private mhDib As Long
Private mhOldDib As Long
Private mPtr As Long
Private mWidthBytes As Long
Public Property Get hDC() As Long
hDC = mhDC
End Property
Public Property Get DataSize() As Long
DataSize = mBmpInfoHeader.biSizeImage
End Property
Public Property Get Width() As Long
Width = mBmpInfoHeader.biWidth
End Property
Public Property Get Height() As Long
Height = mBmpInfoHeader.biHeight
End Property
Public Property Get ColorBit() As Long
ColorBit = mBmpInfoHeader.biBitCount
End Property
Public Property Get DataPtr() As Long
DataPtr = mPtr
End Property
Public Property Get WidthBytes() As Long
WidthBytes = mWidthBytes
End Property
Public Function Create(ByVal NewWidth As Long, ByVal NewHeight As Long, Optional ByVal Bits As Long = 32) As Boolean
Destroy '销毁以前的DIB
mhDC = CreateCompatibleDC(0) '创建DIB设备场景
If (mhDC <> 0) Then '创建成功
With mBmpInfoHeader '位图信息头
.biSize = Len(mBmpInfoHeader)
.biPlanes = 1
.biBitCount = Bits
.biWidth = NewWidth
.biHeight = NewHeight
Select Case Bits
Case 1
mWidthBytes = (((.biWidth + 7) \ 8 + 3) And &HFFFFFFFC)
Case 4
mWidthBytes = (((.biWidth + 1) \ 2 + 3) And &HFFFFFFFC)
Case 8
mWidthBytes = ((.biWidth + 3) And &HFFFFFFFC)
Case 16
mWidthBytes = ((.biWidth * 2 + 3) And &HFFFFFFFC)
Case 24
mWidthBytes = ((.biWidth * 3 + 3) And &HFFFFFFFC)
Case 32
mWidthBytes = .biWidth * 4
Case Else
Exit Function
End Select
.biSizeImage = mWidthBytes * .biHeight
End With
mhDib = CreateDIBSection(mhDC, mBmpInfoHeader, DIB_RGB_COLORS, mPtr, 0, 0) '创建DIB
If (mhDib <> 0) Then
mhOldDib = SelectObject(mhDC, mhDib) '选入设备场景
Else
Destroy '如果DIB创建失败,需销毁DIB设备场景
End If
End If
Create = (mhDib <> 0)
End Function
Public Sub Destroy()
If mhDC <> 0 Then
If mhDib <> 0 Then
SelectObject mhDC, mhOldDib
DeleteObject mhDib
End If
DeleteObject mhDC
mBmpInfoHeader.biBitCount = 0
mBmpInfoHeader.biWidth = 0
mBmpInfoHeader.biHeight = 0
mBmpInfoHeader.biSizeImage = 0
End If
mhDC = 0: mhDib = 0: mhOldDib = 0: mPtr = 0
End Sub
Public Function CreateFromStdPicture(ByVal Picture As StdPicture, Optional Bits As Byte = 32, Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean
Dim Bmp As Bitmap
If GetObject(Picture.handle, Len(Bmp), Bmp) = 0 Then Exit Function
If (GetObjectType(Picture) = OBJ_BITMAP) Then
If Bits = 0 Then Bits = Bmp.bmBitsPixel
Create Bmp.bmWidth, Bmp.bmHeight, Bits
If mhDib <> 0 Then '说明上面的创建函数成功了
Dim SourceDC As Long, OldDib As Long
SourceDC = CreateCompatibleDC(mhDC)
OldDib = SelectObject(SourceDC, Picture.handle)
BitBlt mhDC, 0, 0, Bmp.bmWidth, Bmp.bmHeight, SourceDC, 0, 0, dwRop
SelectObject SourceDC, OldDib
DeleteDC SourceDC
CreateFromStdPicture = True
End If
End If
End Function
Public Function OutPut(ByVal OutDC As Long, Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, Optional ByVal Width As Long, Optional ByVal Height As Long, Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean
If mhDib = 0 Then Exit Function
If Width = 0 Then Width = mBmpInfoHeader.biWidth
If Height = 0 Then Height = mBmpInfoHeader.biHeight
OutPut = BitBlt(OutDC, x, y, Width, Height, mhDC, xSrc, ySrc, dwRop)
End Function
--------------------------------------------------------
Public Function HalfColor() As Boolean
If mhDib = 0 Or Me.ColorBit <> 32 Then Exit Function
Dim i As Long, Maxi As Long
Dim HalfArray(0 To 255) As Byte
Dim DataArr(0 To 2) As Byte, pDataArr(0 To 0) As Long
Dim OldArrPtr As Long, OldpArrPtr As Long
MakePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
Maxi = Me.DataSize \ 4 - 1
pDataArr(0) = Me.DataPtr
For i = 0 To 255
HalfArray(i) = i / 2
Next
For i = 0 To Maxi
DataArr(0) = HalfArray(DataArr(0))
DataArr(1) = HalfArray(DataArr(1))
DataArr(2) = HalfArray(DataArr(2))
pDataArr(0) = pDataArr(0) + 4
Next
FreePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
HalfColor = True
End Function
Public Sub MakePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByRef OldArrPtr As Long, ByRef OldpArrPtr As Long)
Dim Temp As Long, TempPtr As Long
CopyMemory Temp, ByVal DataArrPtr, 4 '得到DataArrPtr的SAFEARRAY结构的地址
Temp = Temp + 12 '这个指针偏移12个字节后就是pvData指针
CopyMemory TempPtr, ByVal pDataArrPtr, 4 '得到pDataArrPtr的SAFEARRAY结构的地址
TempPtr = TempPtr + 12 '这个指针偏移12个字节后就是pvData指针
CopyMemory OldpArrPtr, ByVal TempPtr, 4 '保存旧地址
CopyMemory ByVal TempPtr, Temp, 4 '使pDataArrPtr指向DataArrPtr的SAFEARRAY结构的pvData指针
CopyMemory OldArrPtr, ByVal Temp, 4 '保存旧地址
End Sub
Public Sub FreePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByVal OldArrPtr As Long, ByVal OldpArrPtr As Long)
Dim TempPtr As Long
CopyMemory TempPtr, ByVal DataArrPtr, 4 '得到DataArrPtr的SAFEARRAY结构的地址
CopyMemory ByVal (TempPtr + 12), OldArrPtr, 4 '恢复旧地址
CopyMemory TempPtr, ByVal pDataArrPtr, 4 '得到pDataArrPtr的SAFEARRAY结构的地址
CopyMemory ByVal (TempPtr + 12), OldpArrPtr, 4 '恢复旧地址
End Sub
'--------------------
'窗体测试代码:
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim s As New Class1
Dim t As Long
Private Sub Form_Load()
Dim Imegk As StdPicture
Picture1.AutoRedraw = True
fr = "d:\我的文档\桌面\自画位图资源\Grid编辑扩展位图2.bmp"
If Dir(fr) = "" Then Exit Sub
Set Imegk = LoadPicture(fr)
s.CreateFromStdPicture Imegk, 32
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set s = Nothing
End Sub
Private Sub Command1_Click()
t = GetTickCount
s.HalfColor
s.OutPut Picture1.hDC
Picture1.Refresh
Me.Caption = GetTickCount - t
End Sub