yfskin.ctl

OCX DLL注册工具 OCX DLL注册工具

VERSION 5.00
Begin VB.UserControl YFSkin 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   810
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   1500
   InvisibleAtRuntime=   -1  'True
   LockControls    =   -1  'True
   ScaleHeight     =   810
   ScaleWidth      =   1500
   ToolboxBitmap   =   "YFSkin.ctx":0000
   Begin VB.Timer system 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   1650
      Top             =   1860
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "YFSoft"
      ForeColor       =   &H00FF0000&
      Height          =   225
      Left            =   290
      TabIndex        =   0
      Top             =   50
      Width           =   555
   End
   Begin VB.Image Image1 
      Height          =   240
      Left            =   10
      Picture         =   "YFSkin.ctx":0312
      Top             =   10
      Width           =   240
   End
End
Attribute VB_Name = "YFSkin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************************************************************
'**模 块 名：clsSkins
'**说    明：YFsoft 版权所有2005 - 2006(C)
'**创 建 人：叶帆
'**日    期：2005-03-27 13:22:12
'**修 改 人：
'**日    期：
'**描    述：界面外壳类
'**版    本：V1.0.2
'*************************************************************************
Option Explicit
'---------------------------------------------------------
Private Const HTCAPTION = 2
Private Const HTTOP = 12
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
Private Const HTBOTTOM = 15
Private Const HTBOTTOMLEFT = 16
Private Const HTBOTTOMRIGHT = 17
Private Const HTLEFT = 10
Private Const HTRIGHT = 11
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCLBUTTONUP = &HA2

Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000 '系统菜单
Private Const WS_THICKFRAME = &H40000

Private Type POINTAPI
   X As Long
   Y As Long
End Type

Private Type Rect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long

Private Declare Function PolyDraw Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, lpbTypes As Byte, ByVal cCount As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
    
'---------------------------------------------------------
Private strLanguageFiles() As String       '语言路径信息
Private strLanguageMsg() As String         '语言信息
Private strSelectLanguageFile As String    '当前语言文件
Private lngLanguageNum As Long             '语言信息个数
Private lngLanguageNo As Long              '语言索引

Private strSkinPath As String              '皮肤所在的路径
Private strSkinFiles() As String           '皮肤路径信息
Private strSkinMsg() As String             '皮肤信息
Private lngSkinNum As Long                 '皮肤信息个数
Private lngSkinNo As Long                  '皮肤索引

Private strControlName() As Variant       '加载的控件名称

Private mCaption As String
Private mMaxWindowFlag As Boolean
Private mMaxFlag As Boolean
Private lngLeft As Long
Private lngTop As Long
Private lngRight As Long
Private lngBottom As Long
Private lngWindowW As Long
Private lngWindowH As Long


Private lngOldIndex As Long

Private WithEvents imgIcon As Image
Attribute imgIcon.VB_VarHelpID = -1
Private WithEvents imgCorner0 As Image
Attribute imgCorner0.VB_VarHelpID = -1
Private WithEvents imgCorner1 As Image
Attribute imgCorner1.VB_VarHelpID = -1
Private WithEvents imgCorner2 As Image
Attribute imgCorner2.VB_VarHelpID = -1
Private WithEvents imgCorner3 As Image
Attribute imgCorner3.VB_VarHelpID = -1
Private WithEvents imgBorder0 As Image
Attribute imgBorder0.VB_VarHelpID = -1
Private WithEvents imgBorder1 As Image
Attribute imgBorder1.VB_VarHelpID = -1
Private WithEvents imgBorder2 As Image
Attribute imgBorder2.VB_VarHelpID = -1
Private WithEvents imgTitle As Image
Attribute imgTitle.VB_VarHelpID = -1
Private imgTitleBegin As Image
Private imgTitleEnd As Image
Private WithEvents imgTitleControl As Image
Attribute imgTitleControl.VB_VarHelpID = -1
Private WithEvents imgTitleButton0 As Image
Attribute imgTitleButton0.VB_VarHelpID = -1
Private WithEvents imgTitleButton1 As Image
Attribute imgTitleButton1.VB_VarHelpID = -1
Private WithEvents imgTitleButton2 As Image
Attribute imgTitleButton2.VB_VarHelpID = -1
Private WithEvents lblTitle As Label
Attribute lblTitle.VB_VarHelpID = -1
Private imgTitleCaption  As Image

Private frmWindow As Form
Attribute frmWindow.VB_VarHelpID = -1

'*****************************************************************
'** 函 数 名:ReadIniOne
'** 输    入:String   uFileName 包含包含字段的ini文件名,String   uSection 包含关键字的字段名称,字符数组 uKeyName 关键字名称,
'** 输    出:String
'** 功能描述:此函数根据条件读出*.ini文件中的某一个字段中的某一个关键字的值
'** 全局变量:
'** 调用模块:
'** 作    者:叶帆
'** 日    期:2001年01月
'** 修    改:
'** 日    期:
'** 版    本:V1.0
'****************************************************************
Public Function ReadIniOne(ByVal uFileName As String, ByVal uSectionName As String, ByVal uKeyName As String, Optional strData As String = "") As String
    '打开错误处理陷阱
    On Error GoTo ErrGoto
    '----------------------------------------------------
    '代码正文
    '打开错误处理陷阱
    '----------------------------------------------------
    '代码正文
    Dim StrLong  As Long, Value As String * 255
    Dim strTemp As String

    StrLong = GetPrivateProfileString(uSectionName, uKeyName, "Null", Value, Len(Value), uFileName)
    If StrLong > 0 Then
        'ReadIniOne = Left$(value, StrLong)                      '读取一行
        strTemp = Left$(Value, InStr(1, Value, Chr$(0)) - 1)     '
        If InStr(1, strTemp, ";") > 0 Then
            strTemp = Left$(strTemp, InStr(1, strTemp, ";") - 1) '
        End If
        ReadIniOne = strTemp
      Else
        If Len(strData) > 0 Then
            ReadIniOne = strData
          Else
            ReadIniOne = "Null"
        End If
    End If
    
    ReadIniOne = Replace(ReadIniOne, "#@^@#", "")
    '----------------------------------------------------

Exit Function

    '-----------------------------
ErrGoto:
    If Len(strData) > 0 Then
        ReadIniOne = strData
      Else
        ReadIniOne = "Null"
    End If
End Function

'*************************************************************************
'**函 数 名：WriteIniOne
'**输    入：String uFileName 包含包含字段的ini文件名,String   uSection 包含关键字的字段名称,String uKeyName 关键字名称,
'**          String uKeyValue 关键字的值
'**输    出：long
'**功能描述：此函数根据条件写入*.ini文件中的某个字段中的一个关键字的值
'**全局变量：
'**调用模块：
'**作    者：叶帆
'**日    期：2001年1月
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Public Function WriteIniOne(ByVal uFileName As String, ByVal uSection As String, uKeyName As String, uKeyValue As String) As Long
    '打开错误处理陷阱
    On Error GoTo ErrGoto
    '----------------------------------------------------
    '代码正文
    WriteIniOne = WritePrivateProfileString(uSection, uKeyName, uKeyValue, uFileName)
    '----------------------------------------------------

Exit Function

    '-----------------------------
ErrGoto:
    WriteIniOne = -1

End Function

'*************************************************************************
'**函 数 名：ShowIcon
'**输    入：m_hwnd(Long) -
'**输    出：无
'**功能描述：使任务栏显示图标
'**全局变量：
'**调用模块：
'**作    者：叶帆(来源于似水流年)
'**日    期：2003年07月09日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Private Sub ShowIcon(m_hWnd As Long)
    Dim lStyle As Long
    lStyle = GetWindowLong(m_hWnd, GWL_STYLE) Or WS_SYSMENU Or WS_THICKFRAME
    SetWindowLong m_hWnd, GWL_STYLE, lStyle
End Sub

'*************************************************************************
'**函 数 名：CornerEdit
'**输    入：hwnd - 窗体句柄
'**输    出：无
'**功能描述：圆角处理
'**全局变量：
'**调用模块：
'**作    者：叶帆
'**日    期：2003年04月24日
'**修 改 人：
'**日    期：
'**版    本：版本1.0
'*************************************************************************
Private Sub CornerEdit(hwnd As Long)
    Dim pntXY() As POINTAPI
    Dim lngRgn As Long
    Dim i As Long
    Dim lngRgnNum As Long
    Dim reRect As Rect
    Dim lngWidth As Long
    Dim lngHeight As Long

    Dim lngTemp1 As Long
    Dim lngTemp2 As Long

    DoEvents   '这个必须加
    
    GetWindowRect hwnd, reRect
    lngWidth = reRect.Right - reRect.Left - 6
    lngHeight = reRect.Bottom - reRect.Top - 6
    lngRgnNum = SkinGetData("Bar", "RgnNum", lngTemp2)
    If lngRgnNum > 0 Then
        ReDim pntXY(lngRgnNum)
        
        For i = 0 To lngRgnNum - 1
            lngTemp1 = SkinGetData("Bar", "RgnXY" & Format(i, "0"), lngTemp2)
            If lngTemp1 < 0 Then
                lngTemp1 = lngWidth + lngTemp1
            End If
            If lngTemp2 < 0 Then
                lngTemp2 = lngHeight + lngTemp2
            End If
            If lngTemp1 = 99999 Then
              lngTemp1 = lngWidth
            End If
             If lngTemp2 = 99999 Then
              lngTemp2 = lngHeight
            End If
            
            pntXY(i).X = lngTemp1 + 3
            pntXY(i).Y = lngTemp2 + 3
        Next

        lngRgn = CreatePolygonRgn(pntXY(0), lngRgnNum, 2)
        Call SetWindowRgn(hwnd, lngRgn, True)
        DeleteObject lngRgn
    End If

End Sub

'===========================================================================================
'多语言处理
'===========================================================================================
'*************************************************************************
'**函 数 名：FindLanguage
'**输    入：strLanguageFile()(String)          - 语言文件
'**        ：strLanguage()(String)              - 语言信息
'**        ：Optional strPath(String = "Null")  - 语言路径
'**输    出：(Long) - 语言版本个数
'**功能描述：查找语言版本信息
'**全局变量：
'**调用模块：
'**作    者：叶帆
'**日    期：2004-09-26 20:25:19
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Function FindLanguage(strLanguageFile() As String, strLanguage() As String, Optional strPath As String = "Null") As Long
    On Error GoTo ToExit '打开错误陷阱
    '------------------------------------------------
    Dim lngNum As Long
    Dim strFile As String

    If strPath = "Null" Or Len(strPath) = 0 Then
        strPath = App.Path & "\" & "Language"
        strPath = Replace(strPath, "\\", "\")
    End If

    strFile = Dir(strPath & "\*.ini")

    While strFile <> ""
        lngNum = lngNum + 1
        ReDim Preserve strLanguageFile(lngNum - 1) As String
        ReDim Preserve strLanguage(lngNum - 1) As String
        
        strLanguageFile(lngNum - 1) = strPath & "\" & strFile
        strLanguage(lngNum - 1) = ReadIniOne(strLanguageFile(lngNum - 1), "Info", "Language", "Error")
        
        strFile = Dir()
    Wend

    FindLanguage = lngNum
    '------------------------------------------------
    
    Exit Function

    '----------------
ToExit:
    FindLanguage = 0
End Function

'*************************************************************************
'**函 数 名：GetIniTable
'**输    入：strKey(String)                                   - 键值
'**        ：Optional strFile(String = strSelectLanguageFile) - 文件名
'**输    出：(Long) -
'**功能描述：获取字符串值
'**全局变量：
'**调用模块：
'**作    者：叶帆
'**日    期：2004-09-26 21:21:18
'**修 改 人：
'**日    期：
'**版    本：V1.0.0
'*************************************************************************
Public Function GetIniTable(strKey As String, Optional strFile As String = "") As String
    On Error GoTo ToExit '打开错误陷阱
    '------------------------------------------------

    If Len(strFile) = 0 Then
        If Len(strSelectLanguageFile) = 0 Then
            strSelectLanguageFile = strLanguageFiles(lngLanguageNo)
        End If
        strFile = strSelectLanguageFile
    End If

    GetIniTable = ReadIniOne(strSelectLanguageFile, "String Table", strKey, "Error")

    '------------------------------------------------
    Exit Function
    '----------------
ToExit:
    Resume Next