浏览器

开发平台：
Visual Basic

cImgEx.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cImgEx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'2004-09-11
'可以设置背景色
'可以生成stdpicture
Option Explicit
'==================================================
'============   用于生成stdpicture  ===============
'==================================================
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
'================================================
'================================================
Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
     ByVal hdc As Long, _
     ByVal nWidth As Long, _
     ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
     ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
     ByVal hdc As Long, _
     ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
     ByVal hdc 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 Const SRCCOPY As Long = &HCC0020
     
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private m_created As Boolean 'if created?
'local variable(s) to hold property value(s)
Private mvarhBmp As Long 'local copy
Private mvarhDC As Long 'local copy
Private mvarWidth As Long, mvarHeight As Long
Public Sub Destroy()
Call DeleteObject(mvarhBmp)
Call DeleteDC(mvarhDC)
mvarhBmp = 0
mvarhDC = 0
mvarWidth = 0
mvarHeight = 0
m_created = False
End Sub
Public Property Get hdc() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.hDC
    hdc = mvarhDC
End Property
Public Property Get hBmp() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.hBmp
    hBmp = mvarhBmp
End Property
Public Sub CopyByDc(srcHdc As Long)
If mvarhDC <> 0 Then
    BitBlt mvarhDC, 0, 0, mvarWidth, mvarHeight, srcHdc, 0, 0, SRCCOPY
End If
End Sub
Public Sub CopyByBmp(srcHbmp As Long)
Dim tHdc As Long
Dim tPreObj As Long
If mvarhDC <> 0 Then
    tHdc = CreateCompatibleDC(mvarhDC)
    tPreObj = SelectObject(tHdc, srcHbmp)
    BitBlt mvarhDC, 0, 0, mvarWidth, mvarHeight, tHdc, 0, 0, SRCCOPY
    Call SelectObject(tHdc, tPreObj)
    Call DeleteDC(tHdc)
End If
End Sub
'Public Sub Create(nWidth As Long, nHeight As Long, nDC As Long)
'If mvarhDC <> 0 Or mvarhBmp <> 0 Then Call Destroy
'
'mvarWidth = nWidth: mvarHeight = nHeight
'mvarhBmp = CreateCompatibleBitmap(nDC, nWidth, nHeight)
'mvarhDC = CreateCompatibleDC(nDC)
'Call SelectObject(mvarhDC, mvarhBmp)
'
'End Sub
Public Sub Create(nWidth As Long, nHeight As Long, nDC As Long, Optional color As Long = 0)
'If mvarhDC <> 0 Or mvarhBmp <> 0 Then Call Destroy '
Dim oBmp As Long
If Not m_created Then
    mvarhBmp = CreateCompatibleBitmap(nDC, nWidth, nHeight)
    mvarhDC = CreateCompatibleDC(nDC)
    Call SelectObject(mvarhDC, mvarhBmp)
Else
    mvarhBmp = CreateCompatibleBitmap(nDC, nWidth, nHeight)
    oBmp = SelectObject(mvarhDC, mvarhBmp)
    Call DeleteObject(oBmp)
End If
mvarHeight = nHeight
mvarWidth = nWidth
Call SetColor(color)
''If color <> 0 Then
'    Dim trc As RECT
'    Dim tbr As Long
'
'    trc.Right = nWidth '- 1
'    trc.Bottom = nHeight '- 1
'
'    tbr = CreateSolidBrush(color)
'    Call FillRect(mvarhDC, trc, tbr)
''End If
m_created = True
End Sub
Private Sub Class_Terminate()
If mvarhDC <> 0 Or mvarhBmp <> 0 Then Call Destroy
End Sub
Public Property Get width() As Long
width = mvarWidth
End Property
Public Property Get height() As Long
height = mvarHeight
End Property
Public Sub SetColor(Optional nColor As Long = 0&)
Dim trc As RECT
Dim tbr As Long
trc.Right = mvarWidth
trc.Bottom = mvarHeight
tbr = CreateSolidBrush(nColor)
Call FillRect(mvarhDC, trc, tbr)
DeleteObject tbr
End Sub
'==================================================
'============   用于生成stdpicture  ===============
'==================================================
Private 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)
    'Debug.Print IPic.height
    'Return the new picture
    Set CreateBitmapPicture = IPic
End Function
Private 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
    'Create a compatible device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    'Create a compatible bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    'Select the compatible bitmap into our compatible device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    'Raster capabilities?
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
    'Does our picture use a palette?
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    'What's the size of that palette?
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Set the palette version
        LogPal.palVersion = &H300
        'Number of palette entries
        LogPal.palNumEntries = 256
        'Retrieve the system palette entries
        r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        'Create the palette
        hPal = CreatePalette(LogPal)
        'Select the palette
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        'Realize the palette
        r = RealizePalette(hDCMemory)
    End If
    'Copy the source image to our compatible device context
    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
    'Restore the old bitmap
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Select the palette
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    'Delete our memory DC
    r = DeleteDC(hDCMemory)
    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Public Function ExtractImg(x&, y&, cx&, cy&) As StdPicture
If mvarhDC <> 0 Then
    Set ExtractImg = hDCToPicture(mvarhDC, x, y, cx, cy)
End If
End Function
'index,Zero-based
Public Function ExtractImg2(width&, height&, index&) As StdPicture
If mvarhDC <> 0 Then
    Set ExtractImg2 = hDCToPicture(mvarhDC, width * index, 0, width, height)
End If
End Function
'=======================================================
'=======================================================
'Option Explicit
'
'Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
'     ByVal hdc As Long, _
'     ByVal nWidth As Long, _
'     ByVal nHeight As Long) As Long
'Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
'     ByVal hdc As Long) As Long
'Private Declare Function SelectObject Lib "gdi32" ( _
'     ByVal hdc As Long, _
'     ByVal hObject As Long) As Long
'Private Declare Function DeleteDC Lib "gdi32" ( _
'     ByVal hdc As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" ( _
'     ByVal hObject As Long) As Long
'
'Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
'
'Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
'
'
'Private Type RECT
'    Left As Long
'    Top As Long
'    Right As Long
'    Bottom As Long
'
'End Type
'
'
'Private m_created As Boolean 'if created?
'
'
''local variable(s) to hold property value(s)
'Private mvarhBmp As Long 'local copy
'Private mvarhDC As Long 'local copy
'Private mvarWidth As Long
'Private mvarHeight As Long
'
'Public Sub Destroy()
'Call DeleteDC(mvarhDC)
'Call DeleteObject(mvarhBmp)
'mvarhBmp = 0
'mvarhDC = 0
'
'mvarWidth = 0
'mvarHeight = 0
'm_created = False
'End Sub
'
'
'
'Public Property Get hdc() As Long
''used when retrieving value of a property, on the right side of an assignment.
''Syntax: Debug.Print X.hDC
'    hdc = mvarhDC
'End Property
'
'
'
'Public Property Get hBmp() As Long
''used when retrieving value of a property, on the right side of an assignment.
''Syntax: Debug.Print X.hBmp
'    hBmp = mvarhBmp
'End Property
'
'
'Public Property Get Width() As Long
'    Width = mvarWidth
'End Property
'
'Public Property Get Height() As Long
'    Height = mvarHeight
'End Property
'
'
'Public Sub Create(nWidth As Long, nHeight As Long, nDC As Long, Optional color As Long = 0)
''If mvarhDC <> 0 Or mvarhBmp <> 0 Then Call Destroy '
'Dim oBmp As Long
'
'If Not m_created Then
'    mvarhBmp = CreateCompatibleBitmap(nDC, nWidth, nHeight)
'    mvarhDC = CreateCompatibleDC(nDC)
'    Call SelectObject(mvarhDC, mvarhBmp)
'Else
'    mvarhBmp = CreateCompatibleBitmap(nDC, nWidth, nHeight)
'    oBmp = SelectObject(mvarhDC, mvarhBmp)
'    Call DeleteObject(oBmp)
'End If
'
''If color <> 0 Then
'    Dim trc As RECT
'    Dim tbr As Long
'
'    trc.Right = nWidth '- 1
'    trc.Bottom = nHeight '- 1
'
'    tbr = CreateSolidBrush(color)
'    Call FillRect(mvarhDC, trc, tbr)
''End If
'
'mvarHeight = nHeight
'mvarWidth = nWidth
'
'm_created = True
'End Sub
'
'Private Sub Class_Initialize()
'm_created = False
'End Sub
'
'Private Sub Class_Terminate()
'If mvarhDC <> 0 Or mvarhBmp <> 0 Then Call Destroy
'End Sub
'
'Public Sub SetColor(Optional nColor As Long = 0&)
'Dim trc As RECT
'Dim tbr As Long
'
'trc.Right = mvarWidth
'trc.Bottom = mvarHeight
'
'tbr = CreateSolidBrush(nColor)
'Call FillRect(mvarhDC, trc, tbr)
'
'End Sub
'
'

						