| 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 |
