graygdi.bas

电话本信息 基本上实现电话功能 自己下载侃侃吧

Attribute VB_Name = "GrayGDI"
Option Explicit

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 Type MemHdc
    hdc As Long
    Bmp As Long
    obm As Long
End Type
Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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 DeleteDC Lib "gdi32" (ByVal hdc 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) 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 Long

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Private Function NewMyHdc(dHdc As Long, w As Long, h As Long, Optional Bm As Long) As MemHdc
    With NewMyHdc
        .hdc = CreateCompatibleDC(dHdc)
        If Bm = 0 Then
            .Bmp = CreateCompatibleBitmap(dHdc, w, h)
        Else
            .Bmp = Bm
        End If
        .obm = SelectObject(.hdc, .Bmp)
    End With
End Function

Private Function DelMyHdc(MyHdc As MemHdc, Optional nobmp As Boolean) As MemHdc
    With MyHdc
        If .hdc <> 0 And .obm <> 0 Then SelectObject .hdc, .obm
        If nobmp = False And .Bmp <> 0 Then DeleteObject .Bmp
        If .hdc <> 0 Then DeleteDC .hdc
    End With
End Function

'灰度处理主函数
Public Function GrayBmp(dHdc As Long, x As Long, y As Long, w As Long, h As Long) As Long
    Dim tmpdc As MemHdc
    Dim i As Long, j As Long, m As Long, k As Byte, l As Long
    Dim Bm As BITMAP, AllBytes As Long, LineBytes As Long
    Dim dBits() As Byte
    Dim dBits1() As Integer
    Dim dBits2() As Long
    On Error GoTo last
    With tmpdc
        tmpdc = NewMyHdc(dHdc, w, h)
        GetObj .Bmp, Len(Bm), Bm
        If Bm.bmBitsPixel < 16 Then GoTo last
        BitBlt .hdc, 0, 0, w, h, dHdc, x, y, vbSrcCopy
        LineBytes = Bm.bmWidthBytes
        AllBytes = LineBytes * h
        Select Case Bm.bmBitsPixel
        Case 32
            ReDim dBits2(AllBytes \ 4 - 1)
            GetBitmapBits .Bmp, AllBytes, dBits2(0)
            For i = 0 To AllBytes \ 4 - 1
                dBits2(i) = ((dBits2(i) And &HFF00&) \ &H100) * &H10101
                'dBits2(i) = (dBits2(i) And &HFF) * &H10101'用B值运算
            Next
            SetBitmapBits .Bmp, AllBytes, dBits2(0)
            GrayBmp = 32
        Case 24
            ReDim dBits(AllBytes - 1)
            GetBitmapBits .Bmp, AllBytes, dBits(0)
            For j = 0 To h - 1
                m = j * LineBytes
                For i = m To m + w * 3 - 1 Step 3
                    dBits(i) = dBits(i + 1)
                    dBits(i + 2) = dBits(i)
                Next
            Next
            SetBitmapBits .Bmp, AllBytes, dBits(0)
            GrayBmp = 24
        Case 16
            '按565格式运算
            ReDim dBits1(AllBytes \ 2 - 1)
            GetBitmapBits .Bmp, AllBytes, dBits1(0)
            For j = 0 To h - 1
                m = j * LineBytes \ 2
                For i = m To m + w - 1
                    l = dBits1(i) And &H7C0&
                    l = l * 32 + l + l \ 64
                    CopyMemory dBits1(i), l, 2
                Next
            Next
            SetBitmapBits .Bmp, AllBytes, dBits1(0)
            GrayBmp = 16
        End Select
        BitBlt dHdc, x, y, w, h, .hdc, 0, 0, vbSrcCopy
    End With
last:
    DelMyHdc tmpdc
End Function