Attribute VB_Name = "basManifest"
Option Explicit

' ***************************************************************************
' Module Constants
' ***************************************************************************
  Private Const INVALID_HANDLE_VALUE    As Long = -1
  Private Const VER_PLATFORM_WIN32_NT   As Long = 2
  
  ' Set of bit flags that indicate which common control classes will be loaded
  ' from the DLL. The dwICC value of tagINITCOMMONCONTROLSEX can
  ' be a combination of the following:
  Private Const ICC_LISTVIEW_CLASSES    As Long = &H1   ' listview, header
  Private Const ICC_TREEVIEW_CLASSES    As Long = &H2   ' treeview, tooltips
  Private Const ICC_BAR_CLASSES         As Long = &H4   ' toolbar, statusbar, trackbar, tooltips
  Private Const ICC_TAB_CLASSES         As Long = &H8   ' tab, tooltips
  Private Const ICC_UPDOWN_CLASS        As Long = &H10  ' updown
  Private Const ICC_PROGRESS_CLASS      As Long = &H20  ' progress
  Private Const ICC_HOTKEY_CLASS        As Long = &H40  ' hotkey
  Private Const ICC_ANIMATE_CLASS       As Long = &H80  ' animate
  Private Const ICC_WIN95_CLASSES       As Long = &HFF  ' everything else
  Private Const ICC_DATE_CLASSES        As Long = &H100 ' month picker, date picker, time picker, updown
  Private Const ICC_USEREX_CLASSES      As Long = &H200 ' comboex
  Private Const ICC_COOL_CLASSES        As Long = &H400 ' rebar (coolbar) control

  ' WIN32_IE >= 0x0400
  Private Const ICC_INTERNET_CLASSES    As Long = &H800
  Private Const ICC_PAGESCROLLER_CLASS  As Long = 1000  ' page scroller
  Private Const ICC_NATIVEFNTCTL_CLASS  As Long = 2000  ' native font control

  ' WIN32_WINNT >= 0x501
  Private Const ICC_STANDARD_CLASSES    As Long = 4000
  Private Const ICC_LINK_CLASS          As Long = 8000
  Private Const ALL_FLAGS               As Long = ICC_STANDARD_CLASSES Or ICC_LINK_CLASS Or _
                                                  ICC_NATIVEFNTCTL_CLASS Or ICC_PAGESCROLLER_CLASS Or _
                                                  ICC_INTERNET_CLASSES Or ICC_COOL_CLASSES Or _
                                                  ICC_USEREX_CLASSES Or ICC_DATE_CLASSES Or _
                                                  ICC_WIN95_CLASSES Or ICC_ANIMATE_CLASS Or _
                                                  ICC_HOTKEY_CLASS Or ICC_PROGRESS_CLASS Or _
                                                  ICC_UPDOWN_CLASS Or ICC_TAB_CLASSES Or _
                                                  ICC_BAR_CLASSES Or ICC_TREEVIEW_CLASSES Or _
                                                  ICC_LISTVIEW_CLASSES
                                                    
' ***************************************************************************
' Type structures
' ***************************************************************************
  ' The OSVERSIONINFOEX data structure Contains operating system version information.
  ' The information includes major and minor version numbers, a build number, a
  ' platform identifier, and information about product suites and the latest Service
  ' Pack installed on the system. This structure is used with the GetVersionEx and
  ' VerifyVersionInfo functions.
  Private Type OSVERSIONINFOEX
      OSVSize           As Long         'size, in bytes, of this data structure
      dwVerMajor        As Long         'ie NT 4
      dwVerMinor        As Long         'ie NT 0
      dwBuildNumber     As Long         'ie 1381
                                        'Win9x: build number of the OS in low-order word.
                                        '       High-order word contains major & minor ver nos.
      PlatformID        As Long         'Identifies the operating system platform.
      szCSDVersion      As String * 128 'NT: string, such as "Service Pack 3"
      wServicePackMajor As Integer
      wServicePackMinor As Integer
      wSuiteMask        As Integer
      wProductType      As Byte
      wReserved         As Byte
  End Type

  ' Used with manifest files
  Private Type INIT_COMMON_CTRLS
      dwSize As Long   ' size of this structure
      dwICC  As Long   ' flags indicating which classes to be initialized
  End Type

' ***************************************************************************
' API Declarations
' ***************************************************************************
  ' Retrieves a set of FAT file system attributes for a specified file
  ' or directory. Used here to determine if a path or file exist.
  Private Declare Function GetFileAttributes Lib "kernel32" _
          Alias "GetFileAttributesA" (ByVal lpSpec As String) As Long

  ' Initializes the entire common control dynamic-link library. Exported by
  ' all versions of Comctl32.dll.
  Private Declare Sub InitCommonControls Lib "comctl32" ()
  
  ' Initializes specific common controls classes from the common control
  ' dynamic-link library. Returns TRUE (non-zero) if successful, or FALSE
  ' otherwise. Began being exported with Comctl32.dll version 4.7
  ' (IE3.0 & later).
  Private Declare Function InitCommonControlsEx Lib "comctl32.dll" _
          (iccex As INIT_COMMON_CTRLS) As Boolean

  ' This function obtains extended information about the version of the
  ' operating system that is currently running.
  Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
          (LpVersionInformation As Any) As Long

' ***************************************************************************
' Routine:       InitComctl32
'
' Description:   This will create the XP Manifest file and utilize it. You
'                will only see the results when the exe (not in the IDE)
'                is run.
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' 10-Jan-2006  Randy Birch   rgb@mvps.org
'              http://vbnet.mvps.org/
' 03-DEC-2006  Kenneth Ives  kenaso@tx.rr.com
'              Modified and documented
' ***************************************************************************
Public Sub InitComctl32()

    Dim typICC As INIT_COMMON_CTRLS
    
    CreateManifestFile
         
    On Error GoTo Use_Old_Version
         
    With typICC
        .dwSize = LenB(typICC)
        .dwICC = ALL_FLAGS
    End With
    
    ' VB will generate error 453 "Specified DLL function not found"
    ' if InitCommonControlsEx can't be located in the library. The
    ' error is trapped and the original InitCommonControls is called
    ' instead below.
    If InitCommonControlsEx(typICC) = 0 Then
        InitCommonControls
    End If
    
    On Error GoTo 0
    Exit Sub
    
Use_Old_Version:
    InitCommonControls
    On Error GoTo 0
    
End Sub

' ***************************************************************************
' Routine:       CreateManifestFile
'
' Description:   If this is Windows XP and the manifest file does not exist
'                then one will be created.  If this is not Windows XP and
'                the manifest file exist, it will be deleted.
'
' Parameters:    None.
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' 10-Jan-2006  Randy Birch   rgb@mvps.org
'              http://vbnet.mvps.org/
' 03-DEC-2006  Kenneth Ives  kenaso@tx.rr.com
'              Modified and documented
' ***************************************************************************
Private Sub CreateManifestFile()
    
    Dim hFile       As Long
    Dim strXML      As String
    Dim strFileName As String
    Dim strExeName  As String
    
    On Error Resume Next

    strExeName = App.EXEName        ' EXE name without an extension
    strFileName = IIf(Right$(App.Path, 1) = "\", App.Path, App.Path & "\") & _
                  strExeName & ".exe.manifest"
        
    ' If this is Windows XP or newer and
    ' if the manifest file does not exist
    ' then create it and shutdown this
    ' application.
    If IsWinXPorNewer Then
        
        ' Checks if the manifest has already been created
        If FileExists(strFileName) Then
            Exit Sub
        Else
            ' Create the manifest file
            strXML = "<?xml version=" & Chr$(34) & "1.0" & Chr$(34) & " encoding=" & Chr$(34) & "UTF-8" & Chr$(34) & " standalone=" & Chr$(34) & "yes" & Chr$(34) & "?>"
            strXML = strXML & vbCrLf & "<assembly xmlns=" & Chr$(34) & "urn:schemas-microsoft-com:asm.v1" & Chr$(34) & " manifestVersion=" & Chr$(34) & "1.0" & Chr$(34) & ">"
            strXML = strXML & vbCrLf & "  <assemblyIdentity"
            strXML = strXML & vbCrLf & "    version=" & Chr$(34) & "1.0.0.0" & Chr$(34)
            strXML = strXML & vbCrLf & "    processorArchitecture=" & Chr$(34) & "X86" & Chr$(34)
            strXML = strXML & vbCrLf & "    name=" & Chr$(34) & "Kens.Software." & strExeName & Chr$(34)
            strXML = strXML & vbCrLf & "    type=" & Chr$(34) & "win32" & Chr$(34)
            strXML = strXML & vbCrLf & "  />"
            strXML = strXML & vbCrLf & "  <description>Kens.Software." & strExeName & "</description>"
            strXML = strXML & vbCrLf & "  <dependency>"
            strXML = strXML & vbCrLf & "    <dependentAssembly>"
            strXML = strXML & vbCrLf & "      <assemblyIdentity"
            strXML = strXML & vbCrLf & "        type=" & Chr$(34) & "win32" & Chr$(34)
            strXML = strXML & vbCrLf & "        name=" & Chr$(34) & "Microsoft.Windows.Common-Controls" & Chr$(34)
            strXML = strXML & vbCrLf & "        version=" & Chr$(34) & "6.0.0.0" & Chr$(34)
            strXML = strXML & vbCrLf & "        processorArchitecture=" & Chr$(34) & "X86" & Chr$(34)
            strXML = strXML & vbCrLf & "        publicKeyToken=" & Chr$(34) & "6595b64144ccf1df" & Chr$(34)
            strXML = strXML & vbCrLf & "        language=" & Chr$(34) & "*" & Chr$(34)
            strXML = strXML & vbCrLf & "      />"
            strXML = strXML & vbCrLf & "    </dependentAssembly>"
            strXML = strXML & vbCrLf & "  </dependency>"
            strXML = strXML & vbCrLf & "</assembly>"
            
            hFile = FreeFile
            Open strFileName For Output As #hFile
            Print #hFile, strXML
            Close #hFile
                        
            SetAttr strFileName, vbHidden    ' set the file to be hidden
            
            ' display an appropriate message
            InfoMsg "Manifest file has been re-initialized." & _
                    vbCrLf & vbCrLf & _
                    "This application must be restarted."
            TerminateProgram             ' shutdown this application
        End If
        
    Else
        ' If this is not Windows XP or newer and
        ' if the manifest file does exist then
        ' delete the file because it is not needed.
        If FileExists(strFileName) Then
            SetAttr strFileName, vbNormal
            Kill strFileName
        End If
    End If
    
    On Error GoTo 0
    
End Sub

' ***************************************************************************
' Routine:       FileExists
'
' Description:   Test to see if a file exists.
'
' Syntax:        FileExists("C:\Program Files\Desktop.ini")
'
' Parameters:    strFilename - Path\filename to be queried.
'
' Returns:       True or False
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' dd-mmm-1997  Bruce McKinney "Hardcore Visual Basic"
'              http://vb.mvps.org/hardweb/mckinney.htm
' ***************************************************************************
Private Function FileExists(ByVal strFileName As String) As Boolean
    
    Dim lngAttrib As Long
    
    On Error GoTo FileExists_Exit
    
    lngAttrib = GetFileAttributes(strFileName)

    If (lngAttrib <> INVALID_HANDLE_VALUE) Then
        FileExists = CBool((lngAttrib And vbDirectory) <> vbDirectory)
    End If

FileExists_Exit:

End Function

' ***************************************************************************
' Routine:       IsWinXPorNewer
'
' Description:   Test to see if the operating system is Windows XP or newer.
'
' Parameters:    None.
'
' Returns:       TRUE - Operating system is Windows XP or later
'                FALSE - Earlier version of Windows
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' 10-Jan-2006  Randy Birch   rgb@mvps.org
'              http://vbnet.mvps.org/
' 03-DEC-2006  Kenneth Ives  kenaso@tx.rr.com
'              Modified and documented
' ***************************************************************************
Private Function IsWinXPorNewer() As Boolean

    Dim typOSVIEX As OSVERSIONINFOEX
    
    typOSVIEX.OSVSize = Len(typOSVIEX)
    
    If GetVersionEx(typOSVIEX) = 1 Then
    
        IsWinXPorNewer = (typOSVIEX.PlatformID = VER_PLATFORM_WIN32_NT) And _
                         ((typOSVIEX.dwVerMajor = 5 And typOSVIEX.dwVerMinor >= 1) Or _
                         (typOSVIEX.dwVerMajor >= 6 And typOSVIEX.dwVerMinor >= 0))
    End If

End Function