2.大致上这样～有缺变量声明的自己补上～因为是撷取自某程序中一小段代码～
3.有些是模块里的函式或API就不补了～
4.15种皮肤是内建的～当然还能自行设定更多种类～
Form
程序代码：Option Explicit
Private Sub Form_Initialize()
Set Skin = New ClsSkinChang
End Sub
Private Sub Form_Load()
Call Skin.ChangeThemes(Me, False)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If OCXSetStatus = True Then
If Button = 1 Then
Call Skin.SetSkin(Me)
End If
End If
End Sub
Class
程序代码：Private mvarSindex As Integer 'local copy
Private Const StyleFolder = "Styles"
Public Property Get Sindex() As Integer
Sindex = mvarSindex
End Property
Private Sub Class_Initialize()
InitCommonControls
mvarSindex = 0
Call SkinInit
End Sub
Private Sub SkinInit()
Dim SystemPath As String, OCXPath As String
Dim A As Long
If CheckXDFEnvironment = True Then
SystemPath = GetSysPath & "\" & OCXName
OCXPath = App.Path & "\Styles\" & OCXName
If IsFileExist(OCXPath) = True Then
If IsFileExist(SystemPath) = False Then
FileCopy OCXPath, SystemPath
A = Shell("regsvr32 " & SystemPath & " /s", vbHide)
End If
End If
OCXSetStatus = True
ReDim ThemesString(15)
ThemesString(0) = App.Path & "\Styles\WinXP.Luna.cjstyles" & "," & "NormalBlue.ini"
ThemesString(1) = App.Path & "\Styles\WinXP.Luna.cjstyles" & "," & "NormalAqua.ini"
ThemesString(2) = App.Path & "\Styles\WinXP.Royale.cjstyles" & "," & "NormalRoyale.ini"
ThemesString(3) = App.Path & "\Styles\Office2007.cjstyles" & "," & "NormalBlue.ini"
ThemesString(4) = App.Path & "\Styles\Office2007.cjstyles" & "," & "NormalAqua.ini"
ThemesString(5) = App.Path & "\Styles\Office2007.cjstyles" & "," & "NormalSilver.ini"
ThemesString(6) = App.Path & "\Styles\Office2007.cjstyles" & "," & "NormalBlack.ini"
ThemesString(7) = App.Path & "\Styles\Vista.cjstyles" & "," & "NormalBlue.ini"
ThemesString(8) = App.Path & "\Styles\Vista.cjstyles" & "," & "NormalSilver.ini"
ThemesString(9) = App.Path & "\Styles\Vista.cjstyles" & "," & "NormalBlack.ini"
ThemesString(10) = App.Path & "\Styles\Vista.cjstyles" & "," & "NormalBlack2.ini"
ThemesString(11) = App.Path & "\Styles\Codejock.cjstyles" & "," & "NormalBlue.ini"
ThemesString(12) = App.Path & "\Styles\Codejock.cjstyles" & "," & "NormalBlack.ini"
ThemesString(13) = App.Path & "\Styles\Office2010.cjstyles" & "," & "NormalBlue.ini"
ThemesString(14) = App.Path & "\Styles\Office2010.cjstyles" & "," & "NormalSilver.ini"
ThemesString(15) = App.Path & "\Styles\Office2010.cjstyles" & "," & "NormalBlack.ini"
End If
End Sub
'变换皮肤
Public Sub ChangeThemes(frm As Form, ChangStatus As Boolean)
Dim TPath As String, INI_Name As String, Temp As String
If OCXSetStatus = True Then
If mvarSindex = 0 Then mvarSindex = GetNumber
Temp = ThemesString(mvarSindex)
TPath = Mid$(Temp, 1, InStr(Temp, ",") - 1)
INI_Name = Mid$(Temp, InStr(Temp, ",") + 1, Len(Temp) - InStr(Temp, ","))
With frm
If ChangStatus = True Then
.....
Else
.....
End If
.SkinFramework1.LoadSkin TPath, INI_Name
.SkinFramework1.ApplyWindow .hwnd
.SkinFramework1.ApplyOptions = .SkinFramework1.ApplyOptions Or xtpSkinApplyMetrics
End With
End If
End Sub
'设定随机皮肤
Public Sub SetSkin(frm As Form)
Dim index As Integer
With frm
mvarSindex = GetNumber
.SkinFramework1.LoadSkin Mid(ThemesString(mvarSindex), 1, InStr(ThemesString(mvarSindex), ",") - 1), _
Mid(ThemesString(mvarSindex), InStr(ThemesString(mvarSindex), ",") + 1)
End With
End Sub
Private Function GetNumber() As Integer
Randomize
mvarSindex = Int((UBound(ThemesString) * Rnd) + 1)
GetNumber = mvarSindex
End Function
'运行前环境确认
Public Function CheckXDFEnvironment() As Boolean
On Error GoTo ErrorHandling
CheckXDFEnvironment = True
'App.Path & "\" & StyleFolder
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFolderExist(App.Path & "\" & StyleFolder & "\") = False, False, True)
End If
'WinXP.Luna.cjstyles
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFileExist(App.Path & "\" & StyleFolder & "\WinXP.Luna.cjstyles") = False, False, True)
End If
'WinXP.Royale.cjstyles
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFileExist(App.Path & "\" & StyleFolder & "\WinXP.Royale.cjstyles") = False, False, True)
End If
'Office2007.cjstyles
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFileExist(App.Path & "\" & StyleFolder & "\Office2007.cjstyles") = False, False, True)
End If
'Vista.cjstyles
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFileExist(App.Path & "\" & StyleFolder & "\Vista.cjstyles") = False, False, True)
End If
'Codejock.cjstyles
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFileExist(App.Path & "\" & StyleFolder & "\Codejock.cjstyles") = False, False, True)
End If
'Office2010.cjstyles
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFileExist(App.Path & "\" & StyleFolder & "\Office2010.cjstyles") = False, False, True)
End If
'Codejock.SkinFramework.v15.0.1.ocx
If CheckXDFEnvironment = True Then
CheckXDFEnvironment = IIf(IsFileExist(App.Path & "\" & StyleFolder & "\" & OCXName) = False, False, True)
End If
If CheckXDFEnvironment = False Then
Call ErrorWriteBuff(E_FileName, "0", "CheckXDFEnvironment", Err.Number, Err.Description, "Check Environment Error !")
End If
Exit Function
ErrorHandling:
CheckXDFEnvironment = False
Call ErrorWriteBuff(E_FileName, "0", "CheckXDFEnvironment", Err.Number, Err.Description, "Check Environment Error !")
Resume Next
End Function