Option Explicit
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
Private Declare Function InitCommonControls Lib "Comctl32.dll" () As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Function CreateManifest() As Boolean
'Si hay algun error sigue a la siguiente accion
On Error Resume Next
Dim sPath As String
'Obtenemos la ruta de nuestro ejecutables
sPath = String$(260, Chr$(0)) 'Gracias Cobein
sPath = Left$(sPath, GetModuleFileName(App.hInstance, sPath, Len(sPath)))
'Comprobamos qu eno existe ningun fichero .Manifest _
'y que no estamos ejecutando la aplicacion desde el Visual Studio
If App.LogMode = 0 Then Exit Function
If Dir(sPath & ".manifest", vbReadOnly Or vbSystem Or vbHidden) = vbNullString Then
'Obtenemos la version del Window$
If Win2Version = "XP" Then
'Si es XP significa que es compatible con el metodo Manifest _
', por lo tanto crea el fichero
Open sPath & ".manifest" For Output As #1
'Le introduce los datos...
Print #1, FormatManifest
'Todo ha ido bien...
CreateManifest = True
Close #1
'Estable el fichero como: Oculto/System/SoloLectura/Archivo
SetAttr sPath & ".manifest", vbHidden Or vbSystem Or vbReadOnly Or vbArchive
'Y lo vuelve a ejecutar, para que los cambios tengan efecto
Shell sPath, vbNormalFocus
End
End If
End If
'LLamamos al API....
Call InitCommonControls
End Function
Private Function Win2Version() As String
'Declaramos las variables para esta funcion
Dim OSInf As OSVERSIONINFO, iRet As Integer
OSInf.dwOSVersionInfoSize = 148
OSInf.szCSDVersion = Space$(128)
'Obtenemos la informacion del Window$
iRet = GetVersionExA(OSInf)
'Si no se ha podido obtener correctamente devuelve 'Unknown'
If iRet = 0 Then Win2Version = "Unk": Exit Function
With OSInf
Select Case .dwPlatformId
Case 1
Select Case .dwMinorVersion
Case 0
'En caso de que sea Win95
Win2Version = "95"
Case 10
'En caso de que sea Win98
Win2Version = "98"
Case 90
'En caso de que sea Win Millenium
Win2Version = "Mi"
End Select
Case 2
Select Case .dwMajorVersion
Case 3 Or 4
'En caso de que sea NT (Aqui no he distinguido entre las dos versiones...)
Win2Version = "NT"
Case 5
Select Case .dwMinorVersion
Case 0
'En caso de que sea Win2000
Win2Version = "2000"
Case 1
'En caso de que sea XP
Win2Version = "XP"
Case 2
'En caso de que sea Win2003 (SERVER)
Win2Version = "2003"
End Select
Case 6
'En caso de que sea Win Vista
Win2Version = "Vista"
End Select
Case Else
'En caso de que sea que sea desconocido...
Win2Version = "Unk"
End Select
End With
End Function
Private Function FormatManifest() As String
Dim Header As String
'Carga el .manifest en una variable
Header = "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-8" & Chr(34) & " standalone=" & Chr(34) & "yes" & Chr(34) & "?>" _
& vbCrLf & "<assembly xmlns=" & Chr(34) & "urn:schemas-microsoft-com:asm.v1" & Chr(34) & " manifestVersion=" & Chr(34) & "1.0" & Chr(34) & ">" _
& vbCrLf & "<assemblyIdentity" _
& vbCrLf & "version=" & Chr(34) & "1.0.0.0" & Chr(34) _
& vbCrLf & "processorArchitecture=" & Chr(34) & "X86" & Chr(34) _
& vbCrLf & "name=" & Chr(34) & App.EXEName & ".exe" & Chr(34) _
& vbCrLf & "type=" & Chr(34) & "win32" & Chr(34) _
& vbCrLf & "/>" _
& vbCrLf & "<description>" & App.Comments & "</description>" _
& vbCrLf & "<dependency>" _
& vbCrLf & "<dependentAssembly>" _
& vbCrLf & "<assemblyIdentity" _
& vbCrLf & "type=" & Chr(34) & "win32" & Chr(34) _
& vbCrLf & "name=" & Chr(34) & "Microsoft.Windows.Common-Controls" & Chr(34) _
& vbCrLf & "version=" & Chr(34) & "6.0.0.0" & Chr(34) _
& vbCrLf & "processorArchitecture=" & Chr(34) & "X86" & Chr(34) _
& vbCrLf & "publicKeyToken=" & Chr(34) & "6595b64144ccf1df" & Chr(34) _
& vbCrLf & "language=" & Chr(34) & "*" & Chr(34) _
& vbCrLf & "/>" _
& vbCrLf & "</dependentAssembly>" _
& vbCrLf & "</dependency>" _
& vbCrLf & "</assembly>"
FormatManifest = Header
End Function