migrationanalysis/src/wizard/Utilities.bas

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