Attribute VB_Name = " modManifest " Option Explicit Private Declare Function GetVersionEx() Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As LongPrivate Declare Function ShellExecute()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()Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As INITCOMMONCONTROLSEX_TYPE) As LongPrivate Const ICC_INTERNET_CLASSES = &H800Private Const VER_PLATFORM_WIN32s = 0Private Const VER_PLATFORM_WIN32_WINDOWS = 1Private Const VER_PLATFORM_WIN32_NT = 2Private Enum StartWindowStateEnum StartWindowState START_HIDDEN = 0 START_NORMAL = 4 START_MINIMIZED = 2 START_MAXIMIZED = 3End EnumPrivate Type OSVERSIONINFO OSVSize As Long dwVerMajor As Long dwVerMinor As Long dwBuildNumber As Long PlatformID As Long szCSDVersion As String * 128End TypePrivate Const WinXP = 6Private Type INITCOMMONCONTROLSEX_TYPE dwSize As Long dwICC As LongEnd 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()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 IfEnd SubPrivate Property Get()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 PropertyMakeMANIFESTfile_Err: MakeMANIFESTfile = FalseEnd PropertyPrivate Property Get()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 PropertyIsManifestFile_Err: IsManifestFile = FalseEnd PropertyPrivate Function ShellDocument()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 SelectEnd FunctionPrivate Function Win32Ver()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 IfEnd Function Powered by barenx