图像.bas

非常漂亮的滑动条源代码

Attribute VB_Name = "图像"
Option Explicit

'一下代码均来自网络，非本人原创



Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

 



Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long




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
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _
        ByVal crColor As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc _
        As Long) As Long
Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, _
        ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount _
        As Long, lpBits As Any) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As _
        Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) _
        As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
        ByVal hObject As Long) As Long







Public Sub TransparentBlt(DstDc As Long, _
                          SrcDC As Long, ByVal SrcX As Integer, ByVal SrcY As Integer, _
                          ByVal SrcW As Integer, ByVal SrcH As Integer, DstX As Integer, _
                          DstY As Integer, TransColor As Long)
    '     DstDC - Device context into image is actually drawn
    '进入图像之内的装置上下文实际上被画
    '     SrcDC - Device context of source to be made transparent in color TransColor
    '来源的装置上下文在彩色 TransColor 中被做透明
    '     SrcX, SrcY, SrcW, SrcH - Rectangular region of source bitmap in pixels
    ' 图素的来源位图的矩形区域
    '     DstX, DstY - Coordinates in OutDstDC where the transparent bitmap must go
    '透明的位图一定去的 OutDstDC 的坐标
    '     TransColor - Transparent color

    Dim nRet As Long
    Dim MonoMaskDC As Long, hMonoMask As Long
    Dim MonoInvDC As Long, hMonoInv As Long
    Dim ResultDstDC As Long, hResultDst As Long
    Dim ResultSrcDC As Long, hResultSrc As Long
    Dim hPrevMask As Long, hPrevInv As Long
    Dim hPrevSrc As Long, hPrevDst As Long
    Dim OldBC As Long
    Dim OldMode As Integer

    '创建一个与设备有关的位图，返回位图句柄
    MonoMaskDC = CreateCompatibleDC(DstDc)
    MonoInvDC = CreateCompatibleDC(DstDc)
    '产生单色位图，返回位图句柄
    hMonoMask = CreateBitmap(SrcW, SrcH, 1, 1, ByVal 0&)
    hMonoInv = CreateBitmap(SrcW, SrcH, 1, 1, ByVal 0&)
    hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
    hPrevInv = SelectObject(MonoInvDC, hMonoInv)
    '‘创建一个与特定设备场景一致的内存设备场景
    ResultDstDC = CreateCompatibleDC(DstDc)
    ResultSrcDC = CreateCompatibleDC(DstDc)
    'Create color bitmaps for final result & stored copy of source
    ' 为结局产生彩色位图结果 &储存了来源的副本
    '创建一幅与设备有关位图，它与指定的设备场景兼容
    hResultDst = CreateCompatibleBitmap(DstDc, SrcW, SrcH)
    hResultSrc = CreateCompatibleBitmap(DstDc, SrcW, SrcH)

    hPrevDst = SelectObject(ResultDstDC, hResultDst)
    hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
    ' Copy src to monochrome mask
    ' 副本对单色的假面具的 src
    OldBC = SetBkColor(SrcDC, TransColor)
    nRet = BitBlt(MonoMaskDC, 0, 0, SrcW, SrcH, SrcDC, _
           SrcX, SrcY, vbSrcCopy)
    TransColor = SetBkColor(SrcDC, OldBC)
    ' Create inverse of mask
    '产生假面具的相反
    nRet = BitBlt(MonoInvDC, 0, 0, SrcW, SrcH, MonoMaskDC, _
           0, 0, vbNotSrcCopy)
    'Copy background bitmap to result & create final transparent bitmap
    ' 复印背景位图产生 &产生结局透明位图
    nRet = BitBlt(ResultDstDC, 0, 0, SrcW, SrcH, DstDc, _
           DstX, DstY, vbSrcCopy)

    'AND mask bitmap w/ result DC to punch hole in the background by
    'painting black area for non-transparent portion of source bitmap.
    ' 及戴面具直流以拳重击洞的背景位图 w/ 结果被
    '为来源位图的非透明部分油漆黑色的区域。

    nRet = BitBlt(ResultDstDC, 0, 0, SrcW, SrcH, _
           MonoMaskDC, 0, 0, vbSrcAnd)
    ' Get overlapper
    nRet = BitBlt(ResultSrcDC, 0, 0, SrcW, SrcH, _
           SrcDC, SrcX, SrcY, vbSrcCopy)
    'AND inverse mask w/ source bitmap to turn off bits associated
    'with transparent area of source bitmap by making it black.
    '及相反的戴面具 w/ 来源位图关掉被联合的一点点
    ' 藉由来源位图的透明区域藉由使它黑色。

    nRet = BitBlt(ResultSrcDC, 0, 0, SrcW, SrcH, _
           MonoInvDC, 0, 0, vbSrcAnd)
    'XOR result w/ source bitmap to make background show through.
    'XOR 产生 w/ 来源位图使背景表示过。
    nRet = BitBlt(ResultDstDC, 0, 0, SrcW, SrcH, _
           ResultSrcDC, 0, 0, vbSrcInvert)
    ' Output results
    nRet = BitBlt(DstDc, DstX, DstY, SrcW, SrcH, _
           ResultDstDC, 0, 0, vbSrcCopy)
    ' Clean up
    hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
    DeleteObject hMonoMask
    hMonoInv = SelectObject(MonoInvDC, hPrevInv)
    DeleteObject hMonoInv
    hResultDst = SelectObject(ResultDstDC, hPrevDst)
    DeleteObject hResultDst
    hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
    DeleteObject hResultSrc
    DeleteDC MonoMaskDC
    DeleteDC MonoInvDC
    DeleteDC ResultDstDC
    DeleteDC ResultSrcDC
End Sub


'*************************************************************************
'**函 数 名：TransparencyBlt
'**输    入：ByVal sPicture(Picture) -
'**        ：DstDc(Long)             -
'**        ：SrcX(Integer)           -
'**        ：ScrY(Integer)           -
'**        ：SrcW(Integer)           -
'**        ：SrcH(Integer)           -
'**        ：DetX(Integer)           -
'**        ：DstY(Integer)           -
'**        ：TransparentColor(Long)  -
'**输    出：无
'**功能描述：将一个位图移动到设备场景
'**全局变量：
'**调用模块：
'**作    者：
'**日    期：2006-08-12 13:25:10
'**修 改 人：
'**日    期：
'**版    本：V1.1.21
'*************************************************************************
Public Sub TransparencyBlt(ByVal sPicture As Picture, ByVal DstDc As Long, ByVal SrcX As Integer, ByVal SrcY As Integer, ByVal SrcW As Integer, ByVal SrcH As Integer, ByVal DstX As Integer, ByVal DstY As Integer, ByVal TransparentColor As Long)

    If Not (sPicture Is Nothing) Then
        Dim newDc As Long
        newDc = CreateCompatibleDC(DstDc)
        SelectObject newDc, sPicture
        TransparentBlt DstDc, newDc, SrcX, SrcY, SrcW, SrcH, DstX, DstY, TransparentColor
        DeleteDC newDc
    End If
End Sub

'*************************************************************************
'**函 数 名：hDCToPicture
'**输    入：ByVal hDCSrc(Long)    -
'**        ：ByVal LeftSrc(Long)   -
'**        ：ByVal TopSrc(Long)    -
'**        ：ByVal WidthSrc(Long)  -
'**        ：ByVal HeightSrc(Long) -
'**输    出：(Picture) -
'**功能描述：设备场景转位图
'**全局变量：
'**调用模块：
'**作    者：
'**日    期：2006-08-12 14:16:20
'**修 改 人：
'**日    期：
'**版    本：V1.1.21
'*************************************************************************







Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

    hDCMemory = CreateCompatibleDC(hDCSrc)

    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)

    hBmpPrev = SelectObject(hDCMemory, hBmp)

    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster

    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette

    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then

        LogPal.palVersion = &H300

        LogPal.palNumEntries = 256

        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))

        hPal = CreatePalette(LogPal)

        hPalPrev = SelectPalette(hDCMemory, hPal, 0)

        R = RealizePalette(hDCMemory)
    End If

    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then

        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    R = DeleteDC(hDCMemory)

    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID
    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
        .hBmp = hBmp ' Handle to bitmap
        .hPal = hPal ' Handle to palette (may be null)
    End With
    'Create the picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    'Return the new picture
    Set CreateBitmapPicture = IPic
End Function