1Attribute VB_Name = "Utilities" 2'************************************************************************* 3' 4' Licensed to the Apache Software Foundation (ASF) under one 5' or more contributor license agreements. See the NOTICE file 6' distributed with this work for additional information 7' regarding copyright ownership. The ASF licenses this file 8' to you under the Apache License, Version 2.0 (the 9' "License"); you may not use this file except in compliance 10' with the License. You may obtain a copy of the License at 11' 12' http://www.apache.org/licenses/LICENSE-2.0 13' 14' Unless required by applicable law or agreed to in writing, 15' software distributed under the License is distributed on an 16' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 17' KIND, either express or implied. See the License for the 18' specific language governing permissions and limitations 19' under the License. 20' 21'************************************************************************* 22Option Explicit 23 24Public Const LOCALE_ILANGUAGE As Long = &H1 'language id 25Public Const LOCALE_SLANGUAGE As Long = &H2 'localized name of lang 26Public Const LOCALE_SENGLANGUAGE As Long = &H1001 'English name of lang 27Public Const LOCALE_SABBREVLANGNAME As Long = &H3 'abbreviated lang name 28Public Const LOCALE_SNATIVELANGNAME As Long = &H4 'native name of lang 29Public Const LOCALE_ICOUNTRY As Long = &H5 'country code 30Public Const LOCALE_SCOUNTRY As Long = &H6 'localized name of country 31Public Const LOCALE_SENGCOUNTRY As Long = &H1002 'English name of country 32Public Const LOCALE_SABBREVCTRYNAME As Long = &H7 'abbreviated country name 33Public Const LOCALE_SNATIVECTRYNAME As Long = &H8 'native name of country 34Public Const LOCALE_SINTLSYMBOL As Long = &H15 'intl monetary symbol 35Public Const LOCALE_IDEFAULTLANGUAGE As Long = &H9 'def language id 36Public Const LOCALE_IDEFAULTCOUNTRY As Long = &HA 'def country code 37Public Const LOCALE_IDEFAULTCODEPAGE As Long = &HB 'def oem code page 38Public Const LOCALE_IDEFAULTANSICODEPAGE As Long = &H1004 'def ansi code page 39Public Const LOCALE_IDEFAULTMACCODEPAGE As Long = &H1011 'def mac code page 40 41Public Const LOCALE_IMEASURE As Long = &HD '0 = metric, 1 = US 42Public Const LOCALE_SSHORTDATE As Long = &H1F 'short date format string 43 44'#if(WINVER >= &H0400) 45Public Const LOCALE_SISO639LANGNAME As Long = &H59 'ISO abbreviated language name 46Public Const LOCALE_SISO3166CTRYNAME As Long = &H5A 'ISO abbreviated country name 47'#endif /* WINVER >= as long = &H0400 */ 48 49'#if(WINVER >= &H0500) 50Public Const LOCALE_SNATIVECURRNAME As Long = &H1008 'native name of currency 51Public Const LOCALE_IDEFAULTEBCDICCODEPAGE As Long = &H1012 'default ebcdic code page 52Public Const LOCALE_SSORTNAME As Long = &H1013 'sort name 53'#endif /* WINVER >= &H0500 */ 54 55Public Const CSTR_LOG_FILE_NAME = "analysis.log" 56 57Public Declare Function GetThreadLocale Lib "kernel32" () As Long 58 59Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long 60Public Declare Function GetUserDefaultLCID Lib "kernel32" () As Long 61Public Declare Function GetUserDefaultLangID Lib "kernel32" () As Long 62Public Declare Function GetSystemDefaultLangID Lib "kernel32" () As Long 63 64Public Declare Function GetLocaleInfo Lib "kernel32" _ 65 Alias "GetLocaleInfoA" _ 66 (ByVal Locale As Long, _ 67 ByVal LCType As Long, _ 68 ByVal lpLCData As String, _ 69 ByVal cchData As Long) As Long 70 71Private Const VER_PLATFORM_WIN32s = 0 72Private Const VER_PLATFORM_WIN32_WINDOWS = 1 73Private Const VER_PLATFORM_WIN32_NT = 2 74 75Private Type OSVERSIONINFO 76 OSVSize As Long 'size, in bytes, of this data structure 77 dwVerMajor As Long 'ie NT 3.51, dwVerMajor = 3; NT 4.0, dwVerMajor = 4. 78 dwVerMinor As Long 'ie NT 3.51, dwVerMinor = 51; NT 4.0, dwVerMinor= 0. 79 dwBuildNumber As Long 'NT: build number of the OS 80 'Win9x: build number of the OS in low-order word. 81 ' High-order word contains major & minor ver nos. 82 PlatformID As Long 'Identifies the operating system platform. 83 szCSDVersion As String * 128 'NT: string, such as "Service Pack 3" 84 'Win9x: string providing arbitrary additional information 85End Type 86 87Public Type RGB_WINVER 88 PlatformID As Long 89 VersionName As String 90 VersionNo As String 91 ServicePack As String 92 BuildNo As String 93End Type 94 95'defined As Any to support OSVERSIONINFO and OSVERSIONINFOEX 96Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _ 97 (lpVersionInformation As Any) As Long 98 99Private Declare Function GetDesktopWindow Lib "user32" () As Long 100 101Private Declare Function ShellExecute Lib "shell32" _ 102 Alias "ShellExecuteA" _ 103 (ByVal hWnd As Long, _ 104 ByVal lpOperation As String, _ 105 ByVal lpFile As String, _ 106 ByVal lpParameters As String, _ 107 ByVal lpDirectory As String, _ 108 ByVal nShowCmd As Long) As Long 109 110Public Const SW_SHOWNORMAL As Long = 1 111Public Const SW_SHOWMAXIMIZED As Long = 3 112Public Const SW_SHOWDEFAULT As Long = 10 113Public Const SE_ERR_NOASSOC As Long = 31 114 115Public Const CNO_OPTIONAL_PARAM = "_NoOptionalParam_" 116Private Declare Function WritePrivateProfileString Lib "kernel32" _ 117 Alias "WritePrivateProfileStringA" _ 118 (ByVal lpSectionName As String, _ 119 ByVal lpKeyName As Any, _ 120 ByVal lpString As Any, _ 121 ByVal lpFileName As String) As Long 122 123 124Public Const HKEY_LOCAL_MACHINE As Long = &H80000002 125Public Const HKEY_CLASSES_ROOT = &H80000000 126Private Const ERROR_MORE_DATA = 234 127Private Const ERROR_SUCCESS As Long = 0 128Private Const KEY_QUERY_VALUE As Long = &H1 129Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8 130Private Const KEY_NOTIFY As Long = &H10 131Private Const STANDARD_RIGHTS_READ As Long = &H20000 132Private Const SYNCHRONIZE As Long = &H100000 133Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or _ 134 KEY_QUERY_VALUE Or _ 135 KEY_ENUMERATE_SUB_KEYS Or _ 136 KEY_NOTIFY) And _ 137 (Not SYNCHRONIZE)) 138 139Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _ 140 Alias "RegOpenKeyExA" _ 141 (ByVal hKey As Long, _ 142 ByVal lpSubKey As String, _ 143 ByVal ulOptions As Long, _ 144 ByVal samDesired As Long, _ 145 phkResult As Long) As Long 146 147Private Declare Function RegQueryValueEx Lib "advapi32.dll" _ 148 Alias "RegQueryValueExA" _ 149 (ByVal hKey As Long, _ 150 ByVal lpValueName As String, _ 151 ByVal lpReserved As Long, _ 152 lpType As Long, _ 153 lpData As Any, _ 154 lpcbData As Long) As Long 155 156Private Declare Function RegCloseKey Lib "advapi32.dll" _ 157 (ByVal hKey As Long) As Long 158 159Private Declare Function lstrlenW Lib "kernel32" _ 160 (ByVal lpString As Long) As Long 161 162Private Type ShortItemId 163 cb As Long 164 abID As Byte 165End Type 166 167Private Type ITEMIDLIST 168 mkid As ShortItemId 169End Type 170 171Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _ 172 (ByVal pidl As Long, ByVal pszPath As String) As Long 173 174Private Declare Function SHGetSpecialFolderLocation Lib _ 175 "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder _ 176 As Long, pidl As ITEMIDLIST) As Long 177 178 179Public Function IsWin98Plus() As Boolean 180 'returns True if running Windows 2000 or later 181 Dim osv As OSVERSIONINFO 182 183 osv.OSVSize = Len(osv) 184 185 If GetVersionEx(osv) = 1 Then 186 187 Select Case osv.PlatformID 'win 32 188 Case VER_PLATFORM_WIN32s: 189 IsWin98Plus = False 190 Exit Function 191 Case VER_PLATFORM_WIN32_NT: 'win nt, 2000, xp 192 IsWin98Plus = True 193 Exit Function 194 Case VER_PLATFORM_WIN32_WINDOWS: 195 Select Case osv.dwVerMinor 196 Case 0: 'win95 197 IsWin98Plus = False 198 Exit Function 199 Case 90: 'Windows ME 200 IsWin98Plus = True 201 Exit Function 202 Case 10: ' Windows 98 203 If osv.dwBuildNumber >= 2222 Then 'second edition 204 IsWin98Plus = True 205 Exit Function 206 Else 207 IsWin98Plus = False 208 Exit Function 209 End If 210 End Select 211 Case Else 212 IsWin98Plus = False 213 Exit Function 214 End Select 215 216 End If 217 218End Function 219 220Public Function GetWinVersion(WIN As RGB_WINVER) As String 221 222'returns a structure (RGB_WINVER) 223'filled with OS information 224 225 #If Win32 Then 226 227 Dim osv As OSVERSIONINFO 228 Dim pos As Integer 229 Dim sVer As String 230 Dim sBuild As String 231 232 osv.OSVSize = Len(osv) 233 234 If GetVersionEx(osv) = 1 Then 235 236 'PlatformId contains a value representing the OS 237 WIN.PlatformID = osv.PlatformID 238 239 Select Case osv.PlatformID 240 Case VER_PLATFORM_WIN32s: WIN.VersionName = "Win32s" 241 Case VER_PLATFORM_WIN32_NT: WIN.VersionName = "Windows NT" 242 243 Select Case osv.dwVerMajor 244 Case 4: WIN.VersionName = "Windows NT" 245 Case 5: 246 Select Case osv.dwVerMinor 247 Case 0: WIN.VersionName = "Windows 2000" 248 Case 1: WIN.VersionName = "Windows XP" 249 End Select 250 End Select 251 252 Case VER_PLATFORM_WIN32_WINDOWS: 253 254 'The dwVerMinor bit tells if its 95 or 98. 255 Select Case osv.dwVerMinor 256 Case 0: WIN.VersionName = "Windows 95" 257 Case 90: WIN.VersionName = "Windows ME" 258 Case Else: WIN.VersionName = "Windows 98" 259 End Select 260 261 End Select 262 263 264 'Get the version number 265 WIN.VersionNo = osv.dwVerMajor & "." & osv.dwVerMinor 266 267 'Get the build 268 WIN.BuildNo = (osv.dwBuildNumber And &HFFFF&) 269 270 'Any additional info. In Win9x, this can be 271 '"any arbitrary string" provided by the 272 'manufacturer. In NT, this is the service pack. 273 pos = InStr(osv.szCSDVersion, Chr$(0)) 274 If pos Then 275 WIN.ServicePack = Left$(osv.szCSDVersion, pos - 1) 276 End If 277 278 End If 279 280 #Else 281 282 'can only return that this does not 283 'support the 32 bit call, so must be Win3x 284 WIN.VersionName = "Windows 3.x" 285 #End If 286 GetWinVersion = WIN.VersionName 287 288End Function 289 290Public Sub RunShellExecute(sTopic As String, _ 291 sFile As Variant, _ 292 sParams As Variant, _ 293 sDirectory As Variant, _ 294 nShowCmd As Long) 295 296 Dim hWndDesk As Long 297 Dim success As Long 298 299 'the desktop will be the 300 'default for error messages 301 hWndDesk = GetDesktopWindow() 302 303 'execute the passed operation 304 success = ShellExecute(hWndDesk, sTopic, sFile, sParams, sDirectory, nShowCmd) 305 306 'This is optional. Uncomment the three lines 307 'below to have the "Open With.." dialog appear 308 'when the ShellExecute API call fails 309 If success = SE_ERR_NOASSOC Then 310 Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " & sFile, vbNormalFocus) 311 End If 312 313End Sub 314 315Public Sub WriteToLog(key As String, value As String, _ 316 Optional path As String = CNO_OPTIONAL_PARAM, _ 317 Optional section As String = WIZARD_NAME) 318 319 Static logFile As String 320 321 If logFile = "" Then 322 logFile = GetLogFilePath 323 End If 324 325 If path = "" Then 326 Exit Sub 327 End If 328 329 If path = CNO_OPTIONAL_PARAM Then 330 path = logFile 331 End If 332 Call WritePrivateProfileString(section, key, value, path) 333End Sub 334 335Public Sub WriteDebug(value As String) 336 Static ErrCount As Long 337 Static logFile As String 338 Static debugLevel As Long 339 340 If logFile = "" Then 341 logFile = GetLogFilePath 342 End If 343 344 Dim sSection As String 345 sSection = WIZARD_NAME & "Debug" 346 347 Call WritePrivateProfileString(sSection, "Analysis" & "_debug" & ErrCount, _ 348 value, logFile) 349 ErrCount = ErrCount + 1 350End Sub 351 352Public Function GetDebug(section As String, key As String) As String 353 Static logFile As String 354 355 If logFile = "" Then 356 logFile = GetLogFilePath 357 End If 358 359 GetDebug = ProfileGetItem(section, key, "", logFile) 360End Function 361 362Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, ByVal dwLCType As Long) As String 363 364 Dim sReturn As String 365 Dim r As Long 366 367 'call the function passing the Locale type 368 'variable to retrieve the required size of 369 'the string buffer needed 370 r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) 371 372 'if successful.. 373 If r Then 374 375 'pad the buffer with spaces 376 sReturn = Space$(r) 377 378 'and call again passing the buffer 379 r = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn)) 380 381 'if successful (r > 0) 382 If r Then 383 384 'r holds the size of the string 385 'including the terminating null 386 GetUserLocaleInfo = Left$(sReturn, r - 1) 387 388 End If 389 390 End If 391 392End Function 393 394Public Function GetRegistryInfo(sHive As String, sSubKey As String, sKey As String) As String 395 GetRegistryInfo = "" 396 Dim hKey As Long 397 398 hKey = OpenRegKey(sHive, sSubKey) 399 400 If hKey <> 0 Then 401 GetRegistryInfo = GetRegValue(hKey, sKey) 402 403 'the opened key must be closed 404 Call RegCloseKey(hKey) 405 End If 406End Function 407 408 409Private Function GetRegValue(hSubKey As Long, sKeyName As String) As String 410 411 Dim lpValue As String 'value retrieved 412 Dim lpcbData As Long 'length of retrieved string 413 414 'if valid 415 If hSubKey <> 0 Then 416 417 'Pass an zero-length string to 418 'obtain the required buffer size 419 'required to return the result. 420 'If the key passed exists, the call 421 'will return error 234 (more data) 422 'and lpcbData will indicate the 423 'required buffer size (including 424 'the terminating null). 425 lpValue = "" 426 lpcbData = 0 427 If RegQueryValueEx(hSubKey, _ 428 sKeyName, _ 429 0&, _ 430 0&, _ 431 ByVal lpValue, _ 432 lpcbData) = ERROR_MORE_DATA Then 433 434 lpValue = Space$(lpcbData) 435 436 'retrieve the desired value 437 If RegQueryValueEx(hSubKey, _ 438 sKeyName, _ 439 0&, _ 440 0&, _ 441 ByVal lpValue, _ 442 lpcbData) = ERROR_SUCCESS Then 443 444 GetRegValue = TrimNull(lpValue) 445 446 End If 'If RegQueryValueEx (second call) 447 End If 'If RegQueryValueEx (first call) 448 End If 'If hSubKey 449 450End Function 451 452Private Function OpenRegKey(ByVal hKey As Long, _ 453 ByVal lpSubKey As String) As Long 454 Dim hSubKey As Long 455 Dim retval As Long 456 457 retval = RegOpenKeyEx(hKey, lpSubKey, _ 458 0, KEY_READ, hSubKey) 459 460 If retval = ERROR_SUCCESS Then 461 OpenRegKey = hSubKey 462 End If 463End Function 464 465 466Private Function TrimNull(startstr As String) As String 467 468 TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr))) 469 470End Function 471 472Function GetLogFilePath() As String 473 474 Dim fso As New FileSystemObject 475 Dim TempPath As String 476 477 TempPath = fso.GetSpecialFolder(TemporaryFolder).path 478 479 If (TempPath = "") Then 480 TempPath = "." 481 End If 482 483 GetLogFilePath = fso.GetAbsolutePathName(TempPath & "\" & CSTR_LOG_FILE_NAME) 484End Function 485 486Function GetIniFilePath() As String 487 488 Dim fso As New FileSystemObject 489 Dim AppDataDir As String 490 491 AppDataDir = GetAppDataFolder 492 If (AppDataDir = "") Then 493 AppDataDir = CBASE_RESOURCE_DIR 494 Else 495 If Not fso.FolderExists(AppDataDir) Then 496 fso.CreateFolder (AppDataDir) 497 End If 498 AppDataDir = AppDataDir & "\Sun" 499 If Not fso.FolderExists(AppDataDir) Then 500 fso.CreateFolder (AppDataDir) 501 End If 502 AppDataDir = AppDataDir & "\AnalysisWizard" 503 If Not fso.FolderExists(AppDataDir) Then 504 fso.CreateFolder (AppDataDir) 505 End If 506 End If 507 508 GetIniFilePath = fso.GetAbsolutePathName(AppDataDir & "\" & CANALYSIS_INI_FILE) 509End Function 510 511' This function returns the Application Data Folder Path 512Function GetAppDataFolder() As String 513 Dim idlstr As Long 514 Dim sPath As String 515 Dim IDL As ITEMIDLIST 516 Const NOERROR = 0 517 Const MAX_LENGTH = 260 518 Const CSIDL_APPDATA = &H1A 519 520 On Error GoTo Err_GetFolder 521 522 ' Fill the idl structure with the specified folder item. 523 idlstr = SHGetSpecialFolderLocation(0, CSIDL_APPDATA, IDL) 524 525 If idlstr = NOERROR Then 526 ' Get the path from the idl list, and return 527 ' the folder with a slash at the end. 528 sPath = Space$(MAX_LENGTH) 529 idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) 530 If idlstr Then 531 GetAppDataFolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1) 532 End If 533 End If 534 535Exit_GetFolder: 536 Exit Function 537 538Err_GetFolder: 539 MsgBox "An Error was Encountered" & Chr(13) & Err.Description, _ 540 vbCritical Or vbOKOnly 541 Resume Exit_GetFolder 542 543End Function 544 545 546 547