在VB6,VS2003的程序加XP皮肤

 

在VB6,VS2003的程序加XP皮肤。

一、添加以下部分为模块文件

Option Explicit

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function ShellExecute& Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long)
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As INITCOMMONCONTROLSEX_TYPE) As Long
Private Const ICC_INTERNET_CLASSES = &H800
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Enum StartWindowState
    START_HIDDEN = 0
    START_NORMAL = 4
    START_MINIMIZED = 2
    START_MAXIMIZED = 3
End Enum
Private Type OSVERSIONINFO
    OSVSize As Long
    dwVerMajor As Long
    dwVerMinor As Long
    dwBuildNumber As Long
    PlatformID As Long
    szCSDVersion As String * 128
End Type
Private Const WinXP = 6
Private Type INITCOMMONCONTROLSEX_TYPE
    dwSize As Long
    dwICC As Long
End Type

'=======================================================================
'本模块实现了旧控件对WindowsXP及其以上操作系统的主题的自适应能力.
'本模块代码的创建基于 David Sykes(E-Mail:dsykes@mighty.co.za) 的源代码
'MysticBoy(mysticboys@163.com)删除和修改了本模块.
'警告:要使用此段代码请在模块中保留源作者:David Sykes,修改作者:MysticBoy字样
'注意:请在Sub  Main中调用此函数. Form_Load() 内调用将导致EXE无法启动
'如果您会用eXeScope6.5,请把下面的生成代码Manifest文件的代码删除.
'编译后运行eXeScope6.5 ,向可执行文件中添加XP样式,这样你的程序将也时XP
'如果你没有它建议使用一下代码.第一次使用,请仔细阅读以下代码.
'========================================================================
 
Public Sub InitAppStyle()
    Dim comctls As INITCOMMONCONTROLSEX_TYPE
    Dim retval As Long
    Dim CanProceed As Boolean
    CanProceed = IsManifestFile
    On Error Resume Next
    If Win32Ver > 5 Then
       If MakeMANIFESTfile Then
            With comctls
                .dwSize = Len(comctls)
                .dwICC = ICC_INTERNET_CLASSES
            End With
            retval = InitCommonControlsEx(comctls)
       Else
            CanProceed = True
       End If
    Else
        CanProceed = True
    End If
    If CanProceed = False Then
        '程序需要重新启动
        '如果你的应用程序只能运行一个实例,使用下面的方式决定是否需要退出当前实例 _
          如果你的应用程序允许运行多个实例,请不要使用下面的代码,如果需要,请复制此段代码 _
          来替换您原来的判断代码.注意 您原来的代码可能是: _
               If App.UnattendedApp =True Then   End '如果已经有实例退出.
           '使用此模块后 , 你需要使用的代码如下
           '=============================================================================================
           'If GetSetting(App.ExeName, "Settings", "CanRun") <> "YES" _
               And App.UnattendedApp =Ture  Then
           '    '如果程序启动配置不是"YES",同时有相同实例已经在运行,退出本实例
           '    End
           'End If
           '===============================================================
           '请复制后去处注释符号.
        SaveSetting App.EXEName, "Settings", "CanRun", "YES"
        If ShellDocument(App.Path & "/" & App.EXEName & ".exe", , , , START_NORMAL) Then
            End
            '结束当前进程.
          Else
            SaveSetting App.EXEName, "Settings", "CanRun", "NO"
        End If
    End If
End Sub

Private Property Get MakeMANIFESTfile() As Boolean
    MakeMANIFESTfile = False
    On Local Error GoTo MakeMANIFESTfile_Err
    Dim ManifestFileName As String
    Dim NewFreeFile As Integer
    ManifestFileName = App.Path & "/" & App.EXEName & ".exe.MANIFEST"
    NewFreeFile = FreeFile
    Open ManifestFileName For Output As NewFreeFile
        Print #NewFreeFile, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-8" & Chr(34) & " standalone=" & Chr(34) & "yes" & Chr(34) & "?>"
        Print #NewFreeFile, "<assembly xmlns=" & Chr(34) & "urn:schemas-microsoft-com:asm.v1" & Chr(34) & " manifestVersion=" & Chr(34) & "1.0" & Chr(34) & ">"
        Print #NewFreeFile, "<assemblyIdentity version=" & Chr(34) & "1.0.0.0" & Chr(34) & " processorArchitecture=" & Chr(34) & "x86" & Chr(34) & " & Chr(34) & "prjThemed" & Chr(34) & " type=" & Chr(34) & "Win32" & Chr(34) & " />"
        Print #NewFreeFile, "<dependency>"
        Print #NewFreeFile, "<dependentAssembly>"
        Print #NewFreeFile, "<assemblyIdentity type=" & Chr(34) & "Win32" & Chr(34) & " & Chr(34) & "Microsoft.Windows.Common-Controls" & Chr(34) & " version=" & Chr(34) & "6.0.0.0" & Chr(34) & " processorArchitecture=" & Chr(34) & "x86" & Chr(34) & " publicKeyToken=" & Chr(34) & "6595b64144ccf1df" & Chr(34) & " language=" & Chr(34) & "*" & Chr(34) & " />"
        Print #NewFreeFile, "</dependentAssembly>"
        Print #NewFreeFile, "</dependency>"
        Print #NewFreeFile, "</assembly>"
    Close NewFreeFile
    MakeMANIFESTfile = True
    Exit Property
MakeMANIFESTfile_Err:
    MakeMANIFESTfile = False
End Property

Private Property Get IsManifestFile() As Boolean
    IsManifestFile = False
    On Local Error GoTo IsManifestFile_Err
    Dim ManifestFileName As String
    Dim NewFreeFile As Integer
    ManifestFileName = App.Path & "/" & App.EXEName & ".EXE.MANIFEST"
    NewFreeFile = FreeFile
    Open ManifestFileName For Input Access Read As NewFreeFile
    Close NewFreeFile
    IsManifestFile = True
    Exit Property
IsManifestFile_Err:
    IsManifestFile = False
End Property

Private Function ShellDocument(sDocName As String, _
                    Optional ByVal Action As String = "Open", _
                    Optional ByVal Parameters As String = vbNullString, _
                    Optional ByVal Directory As String = vbNullString, _
                    Optional ByVal WindowState As StartWindowState) As Boolean
    Dim Response
    Response = ShellExecute(&O0, Action, sDocName, Parameters, Directory, WindowState)
    Select Case Response
        Case Is < 33
            ShellDocument = False
        Case Else
            ShellDocument = True
    End Select
End Function
Private Function Win32Ver() As Long
    Dim oOSV As OSVERSIONINFO
    oOSV.OSVSize = Len(oOSV)
    If GetVersionEx(oOSV) = 1 Then
        If (oOSV.PlatformID = VER_PLATFORM_WIN32_NT And oOSV.dwVerMajor = 5 And oOSV.dwVerMinor = 1) Then
           Win32Ver = WinXP
        End If
    End If
End Function

二、在SUB MAIN()中加入InitAppStyle

这样就会自动识别XP的皮肤，在VB6中要用5。0的控件库，尽量不要用FRAME,

否则他里面的控件会跳动刷新，不好看。