我发现了个让老控件自动适应系统主题的代码，我修改好后，给大家公开到着啊，不散分，都对我说谢谢啊！！

MysticBoys 2005-07-23 12:14:39

不知道大家手头有没有这段代码，如果你有这段代码呢。就不当没看这贴子。
要是你没有这段代码，一定要说谢谢哦。
‘=================================

模块：modTheme
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无法启动
'========================================================================

Public Sub InitControlsTheme()
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) & " name=" & 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) & " name=" & 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

模块:modMain

Option Explicit
Public Sub Main()
InitControlsTheme
’然后在现实你的界面。
End Sub
=====================================================================

...全文