Attribute VB_Name = "Utilities" '/************************************************************************* ' * ' DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. ' ' Copyright 2000, 2010 Oracle and/or its affiliates. ' ' OpenOffice.org - a multi-platform office productivity suite ' ' This file is part of OpenOffice.org. ' ' OpenOffice.org is free software: you can redistribute it and/or modify ' it under the terms of the GNU Lesser General Public License version 3 ' only, as published by the Free Software Foundation. ' ' OpenOffice.org is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU Lesser General Public License version 3 for more details ' (a copy is included in the LICENSE file that accompanied this code). ' ' You should have received a copy of the GNU Lesser General Public License ' version 3 along with OpenOffice.org. If not, see ' ' for a copy of the LGPLv3 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