vb 从StdPicture对象创建DIB引用

'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