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