Attribute VB_Name = "Module1"
Option Explicit
Option Base 0

#Const Unicode = True

Private Declare Function CreateDirectoryA Lib "kernel32" (ByVal lpPathName As String, ByVal lpSecurityAttributes As Long) As Long
Private Declare Function CreateDirectoryW Lib "kernel32" (ByVal lpPathName As Long, ByVal lpSecurityAttributes As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As Long) As Long
Private Declare Function SHGetPathFromIDListW Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetSpecialFolderLocationFromSHFolder Lib "shfolder.dll" Alias "SHGetSpecialFolderLocation" (ByVal hWndOwner As Long, ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function GetFileAttributesA Lib "kernel32" (ByVal lpFileName As String) As Long
Private Declare Function GetFileAttributesW Lib "kernel32" (ByVal lpFileName As Long) As Long
Private Declare Function GetCommandLineA Lib "kernel32" () As Long
Private Declare Function GetCommandLineW Lib "kernel32" () As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal HKEY As Long) As Long
Private Declare Function lstrcpynA Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrcpynW Lib "kernel32" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function RegOpenKeyExA Lib "advapi32.dll" (ByVal HKEY As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegOpenKeyExW Lib "advapi32.dll" (ByVal HKEY As Long, ByVal lpSubKey As Long, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal HKEY As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByVal lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegQueryValueExW Lib "advapi32.dll" (ByVal HKEY As Long, ByVal lpValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Sub RtlMoveMemory Lib "kernel32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy 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
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Long
Public IsUnicode As Boolean
Public ptrTemp As Long
Private Const ptrTempSize As Long = 32000 ' int (signed?), so crashes with some apis
Public Const ptrTempSizeX As Long = ptrTempSize - 1&
Public Const ptrTempSizeXW As Long = (ptrTempSize \ 2&) - 1&

Public GetProfileDirectory As String
Public GetProfileDirectory_LongFilenames As Boolean

Public Function CreateDirectoryEx(ByVal FullPath As String) As Boolean
  Dim xChar1 As String
  Dim xLong1 As Long
  
  xLong1 = InStr(FullPath, "\")
  If Not xLong1 = 0& Then
    FullPath = FullPath & "\"
    xChar1 = Left(FullPath, xLong1 - 1&)
    FullPath = Mid(FullPath, xLong1 + 1&)
    Do
      xLong1 = InStr(FullPath, "\")
      If xLong1 = 0& Then
        Exit Do
        Else
        xChar1 = xChar1 & "\" & Left(FullPath, xLong1 - 1&)
        If IsUnicode Then
          Call CreateDirectoryW(StrPtr(xChar1), 0&)
          Else
          Call CreateDirectoryA(xChar1, 0&)
          End If
        FullPath = Mid(FullPath, xLong1 + 1&)
        End If
      Loop
    CreateDirectoryEx = ((GetFileAttributes(xChar1) And 16&) = 16&)
    End If
  End Function

Public Function GetSpecialFolderPath(ByVal nFolder As Long, ByVal SetBackSlash As Boolean) As String
  Dim xLong1 As Long
  Dim xLong2 As Long

  If SHGetSpecialFolderLocation(0&, nFolder, xLong1) = 0& Then
DoWithSHFolderDLL:
    If Not xLong1 = 0& Then
      If IsUnicode Then
        xLong2 = SHGetPathFromIDListW(xLong1, ptrTemp)
        Else
        xLong2 = SHGetPathFromIDListA(xLong1, ptrTemp)
        End If
      If Not xLong2 = 0& Then
        GetSpecialFolderPath = PeekS(ptrTemp)
        If Right(GetSpecialFolderPath, 1&) = "\" Then
          If Not SetBackSlash Then GetSpecialFolderPath = Left(GetSpecialFolderPath, Len(GetSpecialFolderPath) - 1&)
          ElseIf SetBackSlash Then
          GetSpecialFolderPath = GetSpecialFolderPath + "\"
          End If
        End If
      Call CoTaskMemFree(xLong1)
      End If
    Else
    On Error GoTo Er1
    If SHGetSpecialFolderLocationFromSHFolder(0&, nFolder, xLong1) = 0& Then
      On Error GoTo 0
      GoTo DoWithSHFolderDLL
      End If
Rs1:
    On Error GoTo 0
    End If
  Exit Function
  
Er1:
  Resume Rs1
  End Function

Public Function GetFileAttributes(ByVal lpFileName As String) As Long
  If IsUnicode Then
    GetFileAttributes = GetFileAttributesW(StrPtr(lpFileName))
    Else
    GetFileAttributes = GetFileAttributesA(lpFileName)
    End If
  End Function

Public Function AppBase(Optional ByVal ExtensionToAdd As String = vbNullChar) As String
  #If InIDE Then
    Dim xChar1 As String
  
    xChar1 = App.Path
    If Not Right(xChar1, 1&) = "\" Then xChar1 = xChar1 + "\"
    If ExtensionToAdd = Chr(1) Then
      AppBase = xChar1
      Else
      If ExtensionToAdd = vbNullChar Then ExtensionToAdd = "exe"
      AppBase = xChar1 + App.EXEName + "." + ExtensionToAdd
      End If
    #Else

    Static xLong1 As Long
    Static xChar1 As String
    Static xChar2 As String
    Static xChar3 As String
    
    If xLong1 = 0& Then
      If IsUnicode Then
        xChar2 = PeekS(GetCommandLineW)
        Else
        xChar2 = PeekS(GetCommandLineA)
        End If
      If Left(xChar2, 1&) = Chr(34&) Then
        xChar2 = Mid(xChar2, 2&)
        xLong1 = Len(xChar2)
        If Not xLong1 = 0& Then
          xChar2 = Left(xChar2, xLong1 - 1&)
          End If
        xLong1 = InStr(xChar2, Chr(34&))
        Else
        xLong1 = InStr(xChar2, " ")
        End If
      If Not xLong1 = 0& Then
        xChar2 = Left(xChar2, xLong1 - 1&)
        End If
    
      xLong1 = InStrRev(xChar2, "\")
      AppBase = Mid(xChar2, xLong1 + 1&)
      xChar2 = Left(xChar2, xLong1)
      xChar3 = xChar2
      xLong1 = InStrRev(AppBase, ".")
      If xLong1 = 0& Then
        xChar1 = AppBase & "."
        Else
        xChar1 = Left(AppBase, xLong1)
        End If
      Select Case xChar1
        Case LCase(xChar1)
          xLong1 = 1&
        Case UCase(xChar1)
          xLong1 = 2&
        Case Else
          xLong1 = 3&
        End Select
      xChar1 = xChar2 & xChar1
      xChar2 = xChar2 & AppBase
      End If
    
    Select Case ExtensionToAdd
      Case vbNullChar
        AppBase = xChar2
      Case Chr(1&)
        AppBase = xChar3
      Case LCase(ExtensionToAdd), UCase(ExtensionToAdd)
        If xLong1 = 2& Then
          AppBase = xChar1 & UCase(ExtensionToAdd)
          ElseIf xLong1 = 1& Then
          AppBase = xChar1 & LCase(ExtensionToAdd)
          Else
          AppBase = xChar1 & ExtensionToAdd
          End If
      Case Else
        AppBase = xChar1 & ExtensionToAdd
      End Select
    #End If
  End Function

Public Function PeekS(ByVal ptrChar As Long, Optional ByVal MaxLength As Long = -1&) As String
  Dim xLong1 As Long

  If Not ptrChar = 0& Then
    If MaxLength = -1& Then MaxLength = &HFFFF&
    If IsUnicode Then
      xLong1 = lstrlenW(ptrChar)
      If xLong1 > MaxLength Then xLong1 = MaxLength
      PeekS = String(xLong1 + 1&, vbNullChar)
      Call lstrcpynW(StrPtr(PeekS), ptrChar, xLong1 + 1&)
      Else
      xLong1 = lstrlenA(ptrChar)
      If xLong1 > MaxLength Then xLong1 = MaxLength
      PeekS = String(xLong1 + 1&, vbNullChar)
      Call lstrcpynA(PeekS, ptrChar, xLong1 + 1&)
      End If
    PeekS = Left(PeekS, xLong1)
    End If
  End Function

Public Function RegQueryValueEx_String(ByVal HKEY As Long, ByVal lpValueName As String, ByRef ReturnString As String) As Boolean
  Dim xLong1 As Long
  Dim xLong2 As Long

  ReturnString = ""
  xLong1 = ptrTempSizeX
  If IsUnicode Then
    RegQueryValueEx_String = (RegQueryValueExW(HKEY, ByVal StrPtr(lpValueName), 0&, VarPtr(xLong2), ByVal ptrTemp, xLong1) = 0&)
    xLong1 = xLong1 / 2&
    Else
    RegQueryValueEx_String = (RegQueryValueExA(HKEY, lpValueName, 0&, VarPtr(xLong2), ByVal ptrTemp, xLong1) = 0&)
    End If
  If RegQueryValueEx_String And xLong1 > 1& And xLong2 = 1& Then
    ReturnString = PeekS(ptrTemp, xLong1 - 1&)
    Else
    RegQueryValueEx_String = False
    End If
  End Function

#If LoadResEx_IconStuff Then
Public Function ApplicationStart(Optional ByVal MaxIconSupport As Long = 0&) As Boolean
#Else
Public Function ApplicationStart() As Boolean
#End If

  #If Unicode Or LoadResEx_IconStuff Then
    Dim xType1 As OSVERSIONINFO
    #End If
  #If XPTheme_DefControls Or LoadResEx_IconStuff Then
    Dim xLong1 As Long
    #End If

  If ptrTemp = 0& Then
    ptrTemp = LocalAlloc(0&, ptrTempSize)
    If Not ptrTemp = 0& Then
      ApplicationStart = True
      #If XPTheme_DefControls Then
        xLong1 = LoadLibraryA("shell32.dll")
        Call InitCommonControls
        Call FreeLibrary(xLong1)
        #End If

      #If LoadResEx_SetLanguageFile Then
        LoadResEx_LanguageFile_hModule = App.hInstance
        #End If

       #If LoadResEx_IconStuff Then
        xType1.dwOSVersionInfoSize = 148&
        If Not GetVersionExA(xType1) = 0& Then
#If DoEventsEx_Sleep Then
          DoEventsEx_Sleep_WaitableTimers = (xType1.dwPlatformId = &H2&) Or (xType1.dwMajorVersion > 4&) Or (xType1.dwMajorVersion = 4& And xType1.dwMinorVersion >= 10&)
#End If
          If MaxIconSupport > 0& Then
            xLong1 = GetDC(0&)
            If Not xLong1 = 0& Then
              LoadResEx_IsHighColor = (GetDeviceCaps(xLong1, 12&) > 15&)
              Call ReleaseDC(0&, xLong1)
        
              If (xType1.dwPlatformId = &H2&) Then
                'nt series; '2003=5.2
                If xType1.dwMajorVersion > 5& Or xType1.dwMajorVersion = 5& And xType1.dwMinorVersion > 1& Then
                  If LoadResEx_IsHighColor Then
                    LoadResex_Caps_WinDIcon = LoadResEx_IconOS_WinVista
                    Else
                    LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win2000ME_16Color 'LoadResEx_IconOS_WinVista_16Color
                    End If
                  LoadResex_Caps_TrayIcon = LoadResex_Caps_WinDIcon
                  '#If Unicode Then
                  '  IsUnicode = True
                  '  #End If
                  ElseIf xType1.dwMajorVersion = 5& Then
                  If xType1.dwMinorVersion >= 1& Then
                    If LoadResEx_IsHighColor Then
                      LoadResex_Caps_WinDIcon = LoadResEx_IconOS_WinXP
                      Else
                      LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win2000ME_16Color
                      End If
                    LoadResex_Caps_TrayIcon = LoadResex_Caps_WinDIcon
                    Else
                    If LoadResEx_IsHighColor Then
                      LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win2000ME
                      Else
                      LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win2000ME_16Color
                      End If
                    LoadResex_Caps_TrayIcon = LoadResEx_IconOS_Win2000ME_16Color
                    End If
                  '#If Unicode Then
                  '  IsUnicode = True
                  '  #End If
                  Else
                  If LoadResEx_IsHighColor Then
                    LoadResex_Caps_WinDIcon = LoadResEx_IconOS_WinNT
                    'Else
                    'LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win95_16Color
                    End If
                  'LoadResex_Caps_TrayIcon = LoadResEx_IconOS_Win95_16Color
                  End If
                #If Unicode Then
                  IsUnicode = True
                  #End If
                Else
                If xType1.dwMajorVersion > 4& Or xType1.dwMajorVersion = 4& And xType1.dwMinorVersion >= 90& Then
                  If LoadResEx_IsHighColor Then
                    LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win2000ME
                    Else
                    LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win2000ME_16Color
                    End If
                  LoadResex_Caps_TrayIcon = LoadResex_Caps_WinDIcon
                  ElseIf xType1.dwMajorVersion = 4& And xType1.dwMinorVersion >= 10& Then
                  If LoadResEx_IsHighColor Then
                    LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win98
                    'Else
                    'LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win95_16Color
                    End If
                  'LoadResex_Caps_TrayIcon = LoadResEx_IconOS_Win95_16Color
                  Else
                  If LoadResEx_IsHighColor Then
                    LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win95
                    'Else
                    'LoadResex_Caps_WinDIcon = LoadResEx_IconOS_Win95_16Color
                    End If
                  'LoadResex_Caps_TrayIcon = LoadResEx_IconOS_Win95_16Color
                  End If
                End If
              End If
            If LoadResex_Caps_WinDIcon > MaxIconSupport Then
              LoadResex_Caps_WinDIcon = MaxIconSupport
              If LoadResex_Caps_TrayIcon > MaxIconSupport Then LoadResex_Caps_TrayIcon = MaxIconSupport
              End If
            'If ForceHiColorTrayIcons Then LoadResex_Caps_TrayIcon = LoadResex_Caps_WinDIcon
#If Unicode Then
            ElseIf (xType1.dwPlatformId = &H2&) Then
            IsUnicode = True
#End If
            End If
          End If
        #ElseIf Unicode Then
        xType1.dwOSVersionInfoSize = 148&
        If Not GetVersionExA(xType1) = 0& Then
          IsUnicode = (xType1.dwPlatformId = &H2&)
#If DoEventsEx_Sleep Then
          DoEventsEx_Sleep_WaitableTimers = (xType1.dwPlatformId = &H2&) Or (xType1.dwMajorVersion > 4&) Or (xType1.dwMajorVersion = 4& And xType1.dwMinorVersion >= 10&)
#End If
          End If
        #ElseIf DoEventsEx_Sleep Then
        DoEventsEx_Sleep_WaitableTimers = (xType1.dwPlatformId = &H2&) Or (xType1.dwMajorVersion > 4&) Or (xType1.dwMajorVersion = 4& And xType1.dwMinorVersion >= 10&)
        #End If
      #If XPTheme_Auto Then
        Call UpdateTheme
        #End If
      End If
    #If CreateAssemblyFromHexString Then
      Call CreateAssembliesFromHexString
      #End If
    End If
  End Function

Public Sub ApplicationClose()
  #If XPTheme_Auto Then
    Call UnTheme
    #End If
  Call LocalFree(ptrTemp)
  End Sub

Public Function RegOpenKeyEx(ByVal HKEY As Long, ByVal lpSubKey As String, ByVal samDesired As Long, ByRef phkResult As Long) As Boolean
  If IsUnicode Then
    RegOpenKeyEx = (RegOpenKeyExW(HKEY, StrPtr(lpSubKey), 0&, samDesired, phkResult) = 0&)
    Else
    RegOpenKeyEx = (RegOpenKeyExA(HKEY, lpSubKey, 0&, 0&, phkResult) = 0&)
    End If
  End Function




Private Function RegReadString(ByVal uRGSection As String, Optional ByVal uRGName As String) As String
  Dim xLong1 As Long

  If RegOpenKeyEx(&H80000002, uRGSection, 1&, xLong1) Then
    Call RegQueryValueEx_String(xLong1, uRGName, RegReadString)
    RegCloseKey (xLong1)
    End If
  End Function

Public Sub GetProfileDirectory_Init_UseFilenames(ByVal ConfigFilename As String, ByVal ConfigFilenameShort, ByVal AppDirSubPath As String, ByVal AppDirSubPathShort As String)
  Dim xChar1 As String
  Dim xChar2 As String
#If 0 Then
  Dim xType1 As OSVERSIONINFO

  xType1.dwOSVersionInfoSize = 148&
  If Not GetVersionExA(xType1) = 0& Then
    If xType1.dwPlatformId = &H2& And xType1.dwMajorVersion > 5& Then
      GoTo UseAppData
      End If
    End If
  GoTo UseAppData
#End If

  xChar1 = AppBase(Chr(1)) + ConfigFilename
  GetProfileDirectory = AppBase(Chr(1))
  If GetFileAttributes(xChar1) = -1& Then
    xChar1 = AppBase(Chr(1)) + ConfigFilenameShort
    GetProfileDirectory = AppBase(Chr(1))
    If GetFileAttributes(xChar1) = -1& Then
      xChar2 = RegReadString("Software\Microsoft\Windows\CurrentVersion", "ProgramFilesDir")
      If Len(xChar2) = 0& Then
        xChar2 = RegReadString("Software\Microsoft\Windows\CurrentVersion", "ProgramFilesPath")
        If Len(xChar2) = 0& Then
          xChar2 = RegReadString("Software\Microsoft\Windows\CurrentVersion\SETUP\VarLDID", "28700")
          End If
        End If
      If Len(xChar2) = 0& Then
        GoTo UseAppData
        Else
        If Not Right(xChar2, 1&) = "\" Then xChar2 = xChar2 + "\"
        If LCase(Left(AppBase(""), Len(xChar2))) = LCase(xChar2) Then
UseAppData:
          xChar1 = Trim(GetSpecialFolderPath(26&, True))
          If Not Len(xChar1) = 0& Then
            If CreateDirectoryEx(xChar1 & AppDirSubPath) Then
              GetProfileDirectory = xChar1 & AppDirSubPath + "\"
              GetProfileDirectory_LongFilenames = True
              ElseIf CreateDirectoryEx(xChar1 & AppDirSubPathShort) Then
              GetProfileDirectory = xChar1 & AppDirSubPathShort + "\"
              End If
            End If
          End If
        End If
      End If
    Else
    GetProfileDirectory_LongFilenames = True
    End If
  End Sub

Public Sub GetProfileDirectory_Init_UseExtension(ByVal ConfigExtensionToCheckIfExists As String, ByVal AppDirSubPath As String, ByVal AppDirSubPathShort As String, ByVal ConfigFilenamePrefix As String, ByVal ConfigFilenamePrefixShort As String)
  Dim xChar1 As String
  Dim xChar2 As String
#If 0 Then
  Dim xType1 As OSVERSIONINFO

  xType1.dwOSVersionInfoSize = 148&
  If Not GetVersionExA(xType1) = 0& Then
    If xType1.dwPlatformId = &H2& And xType1.dwMajorVersion > 5& Then
      GoTo UseAppData
      End If
    End If
  GoTo UseAppData
#End If
  xChar1 = AppBase(ConfigExtensionToCheckIfExists)
  GetProfileDirectory = AppBase("")
  Debug.Print "#" + xChar1, GetProfileDirectory
  If GetFileAttributes(xChar1) = -1& Then
    xChar2 = RegReadString("Software\Microsoft\Windows\CurrentVersion", "ProgramFilesDir")
    If Len(xChar2) = 0& Then
      xChar2 = RegReadString("Software\Microsoft\Windows\CurrentVersion", "ProgramFilesPath")
      If Len(xChar2) = 0& Then
        xChar2 = RegReadString("Software\Microsoft\Windows\CurrentVersion\SETUP\VarLDID", "28700")
        End If
      End If
    If Len(xChar2) = 0& Then
      GoTo UseAppData
      Else
      If Not Right(xChar2, 1&) = "\" Then xChar2 = xChar2 + "\"
      If LCase(Left(AppBase(""), Len(xChar2))) = LCase(xChar2) Then
UseAppData:
        xChar1 = Trim(GetSpecialFolderPath(26&, True))
        If Not Len(xChar1) = 0& Then
          If CreateDirectoryEx(xChar1 & AppDirSubPath) Then
            If Not Len(ConfigFilenamePrefix) = 0& Then ConfigFilenamePrefix = ConfigFilenamePrefix + "."
            GetProfileDirectory = xChar1 & AppDirSubPath + "\" + ConfigFilenamePrefix
            ElseIf CreateDirectoryEx(xChar1 & AppDirSubPathShort) Then
            If Not Len(ConfigFilenamePrefixShort) = 0& Then ConfigFilenamePrefixShort = ConfigFilenamePrefixShort + "."
            GetProfileDirectory = xChar1 & AppDirSubPathShort + "\" + ConfigFilenamePrefixShort
            End If
          End If
        End If
      End If
    End If
  End Sub

