VB 程序控件自适应XP主题
2013年10月01日
⁄ 综合
⁄ 共 5382字 ⁄ 字号
小 中 大
Attribute VB_Name = "modManifest"
Option Explicit
Private Declare Function GetVersionEx()Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private 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 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 StartWindowStateEnum 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()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()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()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()Function ShellDocument(sDocName As String, _
Optional