clsskinform.cls

大量优秀的vb编程

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsSkinForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function CreateRectRgn Lib "gdi32" _
        (ByVal X1 As Long, _
        ByVal Y1 As Long, _
        ByVal X2 As Long, _
        ByVal Y2 As Long) As Long
        
Private Declare Function CombineRgn Lib "gdi32" _
        (ByVal hDestRgn As Long, _
        ByVal hSrcRgn1 As Long, _
        ByVal hSrcRgn2 As Long, _
        ByVal nCombineMode As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
        (ByVal hObject As Long) As Long

Private Declare Function GetRegionData Lib "gdi32" _
        (ByVal hRgn As Long, _
        ByVal dwCount As Long, _
        lpRgnData As Any) As Long

Private Declare Function ExtCreateRegion Lib "gdi32" _
        (lpXform As Any, _
        ByVal nCount As Long, _
        lpRgnData As Any) As Long

Private Declare Function SetWindowRgn Lib "user32" _
        (ByVal hWnd As Long, _
        ByVal hRgn As Long, _
        ByVal bRedraw As Boolean) As Long
        
Const RGN_DIFF = 4

Dim lRgn As Long

Public Sub CreateRegionFile(PicBox As Control, lTransColour As Long, sFileName As String)
    
    Dim X As Single, Y As Single
    Dim lRgn2 As Long, nBytes As Long
    Dim b() As Byte, iFile As Long
    
    '----Create the Region---------------------------------------------------------
    lRgn = CreateRectRgn(0, 0, PicBox.Width, PicBox.Height)
    For X = 0 To PicBox.Width
        For Y = 0 To PicBox.Height
            If GetPixel(PicBox.hdc, X, Y) = lTransColour Then
                lRgn2 = CreateRectRgn(X, Y, X + 1, Y + 1)
                CombineRgn lRgn, lRgn, lRgn2, RGN_DIFF
                DeleteObject lRgn2
            End If
        Next Y
    Next X
    '------------------------------------------------------------------------------
    
    '----Save to File--------------------------------------------------------------
    nBytes = GetRegionData(lRgn, 0, ByVal 0&)
    If nBytes > 0 Then
         ReDim b(0 To nBytes - 1) As Byte
         If nBytes = GetRegionData(lRgn, nBytes, b(0)) Then
            On Error Resume Next ' Attempt to kill file
            Kill sFileName
            iFile = FreeFile
            Open sFileName For Binary Access Write Lock Read As #iFile
            Put #iFile, , b
            Close #iFile
        End If
    End If
    '-----------------------------------------------------------------------------

End Sub

Private Function RegionFromResource(ResID As Integer, ResType As String) As Long
    
    Dim b() As Byte
    Dim dwCount As Long
    
    b() = LoadResData(ResID, ResType) 'fill b() with the byte array
    dwCount = UBound(b) - LBound(b) + 1 'get length of array
    RegionFromResource = ExtCreateRegion(ByVal 0&, dwCount, b(0)) 'set region

End Function

Private Function JpegFromResource(ResID As Integer, ResType As String) As String

    Dim b() As Byte
    Dim myFile As Long
    Dim tmpFile As String * 260

    GetTempPath Len(tmpFile), tmpFile 'Get temp-directory
    PathAppend tmpFile, "resjpg.tmp" 'easier than If Right(tmpFile, 1)= "\" Then...
    
    b = LoadResData(ResID, ResType) 'fill b() with the byte array
    
    On Error Resume Next ' Attempt to kill file
    Kill tmpFile
    
    myFile = FreeFile 'get next available filenumber
    Open tmpFile For Binary Access Write As #myFile 'access tmpFile
    Put #myFile, , b 'write the byte array to tmpFile
    Close #myFile 'close the file

    JpegFromResource = tmpFile 'return filename with path
    
End Function

Public Sub FormShape(frm As Form, ResRgn As Integer, ResJpg As Integer)

    Dim tmpPic As String
    Dim tmpRgn As Long
    
    tmpPic = JpegFromResource(ResJpg, "JPEG")
    frm.Picture = LoadPicture(tmpPic)
    
    On Error Resume Next
    Kill tmpPic
    
    tmpRgn = RegionFromResource(ResRgn, "RGN")
    SetWindowRgn frm.hWnd, tmpRgn, True

End Sub