modbitmap.bas

来自「大量优秀的vb编程」· BAS 代码 · 共 90 行

Attribute VB_Name = "modBitmap"
Option Explicit

Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

Function GetRValue&(ByVal rgbColor&)
'-----------------------------------------------------------------
    GetRValue = rgbColor And &HFF
'-----------------------------------------------------------------
End Function
'==================================================================


'==================================================================
'
Function GetGValue&(ByVal rgbColor&)
'-----------------------------------------------------------------
    GetGValue = (rgbColor And &HFF00&) / &HFF&
'-----------------------------------------------------------------
End Function
'==================================================================


'
Function GetBValue&(ByVal rgbColor&)
'-----------------------------------------------------------------
    GetBValue = (rgbColor& And &HFF0000) / &HFF00&
'-----------------------------------------------------------------
End Function
'==================================================================


'
Sub ChangetoGray(ByVal SrcDC&, _
                 ByVal nx&, _
                 ByVal ny&, _
                 Optional ByVal nMaskColor& = -1)
'-----------------------------------------------------------------
    Dim rgbColor&, Gray&
    Dim RValue&, GValue&, BValue&
    Dim dl&
    
    'get color.
    rgbColor = GetPixel(SrcDC, nx, ny)
    
    'if rgbColor=MaskColor, don't chang the color
    If rgbColor = nMaskColor Then GoTo Release:
    
    'get color rgb heft.
    RValue = GetRValue(rgbColor)
    GValue = GetGValue(rgbColor)
    BValue = GetBValue(rgbColor)
    
    'set new color
    Gray = (9798 * RValue + 19235 * GValue + 3735 * BValue) / 32768 'Change wffs
    
    rgbColor = RGB(Gray, Gray, Gray)
    
    dl& = SetPixelV(SrcDC, nx, ny, rgbColor)
    
Release:
    rgbColor = 0: Gray = 0
    RValue = 0: GValue = 0: BValue = 0
    dl = 0
'-----------------------------------------------------------------
End Sub
'==================================================================

'
Sub DrawGrayBitmap(ByVal hdc&, _
                   ByVal nx&, _
                   ByVal ny&, _
                   ByVal nWidth&, _
                   ByVal nHeight&, _
                   Optional ByVal nMaskColor& = -1)
'-----------------------------------------------------------------
    Dim i&, j&
    
    'Chang the bitmap to gray bitmap in hdc.
    For i = nx To nWidth
        For j = ny To nHeight
            'Call ChangetoGray function
            ChangetoGray hdc, i, j, nMaskColor
        Next j
    Next i
'-----------------------------------------------------------------
End Sub
'==================================================================