1.要进行编译请先自行安装Codejock.Xtreme.Suite.Pro.ActiveX v15.3.1
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