xref: /aoo41x/main/migrationanalysis/src/wizard/Utilities.bas (revision e76eebc6)

Attribute VB_Name = "Utilities"
'*************************************************************************
'
'  Licensed to the Apache Software Foundation (ASF) under one
'  or more contributor license agreements.  See the NOTICE file
'  distributed with this work for additional information
'  regarding copyright ownership.  The ASF licenses this file
'  to you under the Apache License, Version 2.0 (the
'  "License"); you may not use this file except in compliance
'  with the License.  You may obtain a copy of the License at
'
'    http://www.apache.org/licenses/LICENSE-2.0
'
'  Unless required by applicable law or agreed to in writing,
'  software distributed under the License is distributed on an
'  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
'  KIND, either express or implied.  See the License for the
'  specific language governing permissions and limitations
'  under the License.
'
'*************************************************************************
Option Explicit

Public Const LOCALE_ILANGUAGE             As Long = &H1    'language id
Public Const LOCALE_SLANGUAGE             As Long = &H2    'localized name of lang
Public Const LOCALE_SENGLANGUAGE          As Long = &H1001 'English name of lang
Public Const LOCALE_SABBREVLANGNAME       As Long = &H3    'abbreviated lang name
Public Const LOCALE_SNATIVELANGNAME       As Long = &H4    'native name of lang
Public Const LOCALE_ICOUNTRY              As Long = &H5    'country code
Public Const LOCALE_SCOUNTRY              As Long = &H6    'localized name of country
Public Const LOCALE_SENGCOUNTRY           As Long = &H1002 'English name of country
Public Const LOCALE_SABBREVCTRYNAME       As Long = &H7    'abbreviated country name
Public Const LOCALE_SNATIVECTRYNAME       As Long = &H8    'native name of country
Public Const LOCALE_SINTLSYMBOL           As Long = &H15   'intl monetary symbol
Public Const LOCALE_IDEFAULTLANGUAGE      As Long = &H9    'def language id
Public Const LOCALE_IDEFAULTCOUNTRY       As Long = &HA    'def country code
Public Const LOCALE_IDEFAULTCODEPAGE      As Long = &HB    'def oem code page
Public Const LOCALE_IDEFAULTANSICODEPAGE  As Long = &H1004 'def ansi code page
Public Const LOCALE_IDEFAULTMACCODEPAGE   As Long = &H1011 'def mac code page

Public Const LOCALE_IMEASURE              As Long = &HD     '0 = metric, 1 = US
Public Const LOCALE_SSHORTDATE            As Long = &H1F    'short date format string

'#if(WINVER >=  &H0400)
Public Const LOCALE_SISO639LANGNAME       As Long = &H59   'ISO abbreviated language name
Public Const LOCALE_SISO3166CTRYNAME      As Long = &H5A   'ISO abbreviated country name
'#endif /* WINVER >= as long = &H0400 */

'#if(WINVER >=  &H0500)
Public Const LOCALE_SNATIVECURRNAME        As Long = &H1008 'native name of currency
Public Const LOCALE_IDEFAULTEBCDICCODEPAGE As Long = &H1012 'default ebcdic code page
Public Const LOCALE_SSORTNAME              As Long = &H1013 'sort name
'#endif /* WINVER >=  &H0500 */

Public Const CSTR_LOG_FILE_NAME = "analysis.log"

Public Declare Function GetThreadLocale Lib "kernel32" () As Long

Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Public Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Public Declare Function GetUserDefaultLangID Lib "kernel32" () As Long
Public Declare Function GetSystemDefaultLangID Lib "kernel32" () As Long

Public Declare Function GetLocaleInfo Lib "kernel32" _
   Alias "GetLocaleInfoA" _
  (ByVal Locale As Long, _
   ByVal LCType As Long, _
   ByVal lpLCData As String, _
   ByVal cchData As Long) As Long

Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2

Private Type OSVERSIONINFO
  OSVSize         As Long         'size, in bytes, of this data structure
  dwVerMajor      As Long         'ie NT 3.51, dwVerMajor = 3; NT 4.0, dwVerMajor = 4.
  dwVerMinor      As Long         'ie NT 3.51, dwVerMinor = 51; NT 4.0, dwVerMinor= 0.
  dwBuildNumber   As Long         'NT: build number of the OS
                                  '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"
                                  'Win9x: string providing arbitrary additional information
End Type

Public Type RGB_WINVER
  PlatformID      As Long
  VersionName     As String
  VersionNo       As String
  ServicePack     As String
  BuildNo         As String
End Type

'defined As Any to support OSVERSIONINFO and OSVERSIONINFOEX
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
  (lpVersionInformation As Any) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function ShellExecute Lib "shell32" _
    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) As Long

Public Const SW_SHOWNORMAL As Long = 1
Public Const SW_SHOWMAXIMIZED As Long = 3
Public Const SW_SHOWDEFAULT As Long = 10
Public Const SE_ERR_NOASSOC As Long = 31

Public Const CNO_OPTIONAL_PARAM = "_NoOptionalParam_"
Private Declare Function WritePrivateProfileString Lib "kernel32" _
   Alias "WritePrivateProfileStringA" _
  (ByVal lpSectionName As String, _
   ByVal lpKeyName As Any, _
   ByVal lpString As Any, _
   ByVal lpFileName As String) As Long


Public Const HKEY_LOCAL_MACHINE  As Long = &H80000002
Public Const HKEY_CLASSES_ROOT = &H80000000
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_SUCCESS As Long = 0
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const STANDARD_RIGHTS_READ As Long = &H20000
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or _
                                   KEY_QUERY_VALUE Or _
                                   KEY_ENUMERATE_SUB_KEYS Or _
                                   KEY_NOTIFY) And _
                                   (Not SYNCHRONIZE))

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
   Alias "RegOpenKeyExA" _
  (ByVal hKey As Long, _
   ByVal lpSubKey As String, _
   ByVal ulOptions As Long, _
   ByVal samDesired As Long, _
   phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
   Alias "RegQueryValueExA" _
  (ByVal hKey As Long, _
   ByVal lpValueName As String, _
   ByVal lpReserved As Long, _
   lpType As Long, _
   lpData As Any, _
   lpcbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _
  (ByVal hKey As Long) As Long

Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long

Private Type ShortItemId
   cb As Long
   abID As Byte
End Type

Private Type ITEMIDLIST
   mkid As ShortItemId
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
   (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare Function SHGetSpecialFolderLocation Lib _
   "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder _
   As Long, pidl As ITEMIDLIST) As Long


Public Function IsWin98Plus() As Boolean
    'returns True if running Windows 2000 or later
    Dim osv As OSVERSIONINFO

    osv.OSVSize = Len(osv)

    If GetVersionEx(osv) = 1 Then

       Select Case osv.PlatformID 'win 32
            Case VER_PLATFORM_WIN32s:
                IsWin98Plus = False
                Exit Function
            Case VER_PLATFORM_WIN32_NT: 'win nt, 2000, xp
                IsWin98Plus = True
                Exit Function
            Case VER_PLATFORM_WIN32_WINDOWS:
                Select Case osv.dwVerMinor
                    Case 0: 'win95
                        IsWin98Plus = False
                        Exit Function
                    Case 90:   'Windows ME
                        IsWin98Plus = True
                        Exit Function
                    Case 10:   ' Windows 98
                        If osv.dwBuildNumber >= 2222 Then 'second edition
                            IsWin98Plus = True
                            Exit Function
                        Else
                            IsWin98Plus = False
                            Exit Function
                        End If
                End Select
            Case Else
                IsWin98Plus = False
                Exit Function
      End Select

    End If

End Function

Public Function GetWinVersion(WIN As RGB_WINVER) As String

'returns a structure (RGB_WINVER)
'filled with OS information

  #If Win32 Then

   Dim osv As OSVERSIONINFO
   Dim pos As Integer
   Dim sVer As String
   Dim sBuild As String

   osv.OSVSize = Len(osv)

   If GetVersionEx(osv) = 1 Then

     'PlatformId contains a value representing the OS
      WIN.PlatformID = osv.PlatformID

      Select Case osv.PlatformID
         Case VER_PLATFORM_WIN32s:   WIN.VersionName = "Win32s"
         Case VER_PLATFORM_WIN32_NT: WIN.VersionName = "Windows NT"

         Select Case osv.dwVerMajor
            Case 4:  WIN.VersionName = "Windows NT"
            Case 5:
            Select Case osv.dwVerMinor
               Case 0:  WIN.VersionName = "Windows 2000"
               Case 1:  WIN.VersionName = "Windows XP"
            End Select
        End Select

         Case VER_PLATFORM_WIN32_WINDOWS:

          'The dwVerMinor bit tells if its 95 or 98.
            Select Case osv.dwVerMinor
               Case 0:    WIN.VersionName = "Windows 95"
               Case 90:   WIN.VersionName = "Windows ME"
               Case Else: WIN.VersionName = "Windows 98"
            End Select

      End Select


     'Get the version number
      WIN.VersionNo = osv.dwVerMajor & "." & osv.dwVerMinor

     'Get the build
      WIN.BuildNo = (osv.dwBuildNumber And &HFFFF&)

     'Any additional info. In Win9x, this can be
     '"any arbitrary string" provided by the
     'manufacturer. In NT, this is the service pack.
      pos = InStr(osv.szCSDVersion, Chr$(0))
      If pos Then
         WIN.ServicePack = Left$(osv.szCSDVersion, pos - 1)
      End If

   End If

  #Else

    'can only return that this does not
    'support the 32 bit call, so must be Win3x
     WIN.VersionName = "Windows 3.x"
  #End If
  GetWinVersion = WIN.VersionName

End Function

Public Sub RunShellExecute(sTopic As String, _
                           sFile As Variant, _
                           sParams As Variant, _
                           sDirectory As Variant, _
                           nShowCmd As Long)

   Dim hWndDesk As Long
   Dim success As Long

  'the desktop will be the
  'default for error messages
   hWndDesk = GetDesktopWindow()

  'execute the passed operation
   success = ShellExecute(hWndDesk, sTopic, sFile, sParams, sDirectory, nShowCmd)

  'This is optional. Uncomment the three lines
  'below to have the "Open With.." dialog appear
  'when the ShellExecute API call fails
  If success = SE_ERR_NOASSOC Then
     Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " & sFile, vbNormalFocus)
  End If

End Sub

Public Sub WriteToLog(key As String, value As String, _
    Optional path As String = CNO_OPTIONAL_PARAM, _
    Optional section As String = WIZARD_NAME)

    Static logFile As String

    If logFile = "" Then
        logFile = GetLogFilePath
    End If

    If path = "" Then
        Exit Sub
    End If

    If path = CNO_OPTIONAL_PARAM Then
        path = logFile
    End If
    Call WritePrivateProfileString(section, key, value, path)
End Sub

Public Sub WriteDebug(value As String)
    Static ErrCount As Long
    Static logFile As String
    Static debugLevel As Long

    If logFile = "" Then
        logFile = GetLogFilePath
    End If

    Dim sSection As String
    sSection = WIZARD_NAME & "Debug"

    Call WritePrivateProfileString(sSection, "Analysis" & "_debug" & ErrCount, _
        value, logFile)
    ErrCount = ErrCount + 1
End Sub

Public Function GetDebug(section As String, key As String) As String
    Static logFile As String

    If logFile = "" Then
        logFile = GetLogFilePath
    End If

    GetDebug = ProfileGetItem(section, key, "", logFile)
End Function

Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String

   Dim sReturn As String
   Dim r As Long

  'call the function passing the Locale type
  'variable to retrieve the required size of
  'the string buffer needed
   r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))

  'if successful..
   If r Then

     'pad the buffer with spaces
      sReturn = Space$(r)

     'and call again passing the buffer
      r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))

     'if successful (r > 0)
      If r Then

        'r holds the size of the string
        'including the terminating null
         GetUserLocaleInfo = Left$(sReturn, r - 1)

      End If

   End If

End Function

Public Function GetRegistryInfo(sHive As String, sSubKey As String, sKey As String) As String
    GetRegistryInfo = ""
    Dim hKey As Long

    hKey = OpenRegKey(sHive, sSubKey)

    If hKey <> 0 Then
       GetRegistryInfo = GetRegValue(hKey, sKey)

      'the opened key must be closed
       Call RegCloseKey(hKey)
    End If
End Function


Private Function GetRegValue(hSubKey As Long, sKeyName As String) As String

   Dim lpValue As String   'value retrieved
   Dim lpcbData As Long    'length of retrieved string

  'if valid
   If hSubKey <> 0 Then

     'Pass an zero-length string to
     'obtain the required buffer size
     'required to return the result.
     'If the key passed exists, the call
     'will return error 234 (more data)
     'and lpcbData will indicate the
     'required buffer size (including
     'the terminating null).
      lpValue = ""
      lpcbData = 0
      If RegQueryValueEx(hSubKey, _
                         sKeyName, _
                         0&, _
                         0&, _
                         ByVal lpValue, _
                         lpcbData) = ERROR_MORE_DATA Then

         lpValue = Space$(lpcbData)

        'retrieve the desired value
         If RegQueryValueEx(hSubKey, _
                            sKeyName, _
                            0&, _
                            0&, _
                            ByVal lpValue, _
                            lpcbData) = ERROR_SUCCESS Then

            GetRegValue = TrimNull(lpValue)

         End If  'If RegQueryValueEx (second call)
      End If  'If RegQueryValueEx (first call)
   End If  'If hSubKey

End Function

Private Function OpenRegKey(ByVal hKey As Long, _
                            ByVal lpSubKey As String) As Long
    Dim hSubKey As Long
    Dim retval As Long

    retval = RegOpenKeyEx(hKey, lpSubKey, _
                          0, KEY_READ, hSubKey)

    If retval = ERROR_SUCCESS Then
        OpenRegKey = hSubKey
    End If
End Function


Private Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))

End Function

Function GetLogFilePath() As String

    Dim fso As New FileSystemObject
    Dim TempPath As String

    TempPath = fso.GetSpecialFolder(TemporaryFolder).path

    If (TempPath = "") Then
        TempPath = "."
    End If

    GetLogFilePath = fso.GetAbsolutePathName(TempPath & "\" & CSTR_LOG_FILE_NAME)
End Function

Function GetIniFilePath() As String

    Dim fso As New FileSystemObject
    Dim AppDataDir As String

    AppDataDir = GetAppDataFolder
    If (AppDataDir = "") Then
        AppDataDir = CBASE_RESOURCE_DIR
    Else
        If Not fso.FolderExists(AppDataDir) Then
            fso.CreateFolder (AppDataDir)
        End If
        AppDataDir = AppDataDir & "\Sun"
        If Not fso.FolderExists(AppDataDir) Then
            fso.CreateFolder (AppDataDir)
        End If
        AppDataDir = AppDataDir & "\AnalysisWizard"
        If Not fso.FolderExists(AppDataDir) Then
            fso.CreateFolder (AppDataDir)
        End If
    End If

    GetIniFilePath = fso.GetAbsolutePathName(AppDataDir & "\" & CANALYSIS_INI_FILE)
End Function

' This function returns the Application Data Folder Path
Function GetAppDataFolder() As String
   Dim idlstr As Long
   Dim sPath As String
   Dim IDL As ITEMIDLIST
   Const NOERROR = 0
   Const MAX_LENGTH = 260
   Const CSIDL_APPDATA = &H1A

   On Error GoTo Err_GetFolder

   ' Fill the idl structure with the specified folder item.
   idlstr = SHGetSpecialFolderLocation(0, CSIDL_APPDATA, IDL)

   If idlstr = NOERROR Then
       ' Get the path from the idl list, and return
       ' the folder with a slash at the end.
       sPath = Space$(MAX_LENGTH)
       idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
       If idlstr Then
           GetAppDataFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
       End If
   End If

Exit_GetFolder:
    Exit Function

Err_GetFolder:
   MsgBox "An Error was Encountered" & Chr(13) & Err.Description, _
      vbCritical Or vbOKOnly
   Resume Exit_GetFolder

End Function