Attribute VB_Name = "modWizard" | |
'************************************************************************* | |
' | |
' 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 | |
Global Const WIZARD_NAME = "Analysis" | |
'Implementation details - not required for localisation | |
Public Const CWORD_DRIVER_FILE = "_OOoDocAnalysisWordDriver.doc" | |
Public Const CEXCEL_DRIVER_FILE = "_OOoDocAnalysisExcelDriver.xls" | |
Public Const CPP_DRIVER_FILE = "_OOoDocAnalysisPPTDriver.ppt" | |
Public Const CRESULTS_TEMPLATE_FILE = "results.xlt" | |
Public Const CISSUES_LIST_FILE = "issues.list" | |
Public Const CANALYSIS_INI_FILE = "analysis.ini" | |
Public Const CLAUNCH_DRIVERS_EXE = "LaunchDrivers.exe" | |
Public Const CMSO_KILL_EXE = "msokill.exe" | |
Public Const CRESOURCE_DLL = "Resources.dll" | |
' Preparation String ID's from DocAnalysisWizard.rc | |
Public Const RID_STR_ENG_TITLE_PREP_ID = 1030 | |
Public Const RID_STR_ENG_SIDEBAR_ANALYZE_PREP_ID = 1074 | |
Public Const RID_STR_ENG_INTRODUCTION_INTRO1_PREP_ID = 1131 | |
Public Const RID_STR_ENG_INTRODUCTION_INTRO2_PREP_ID = 1132 | |
Public Const RID_STR_ENG_INTRODUCTION_INTRO3_PREP_ID = 1134 | |
Public Const RID_STR_ENG_DOCUMENTS_CHOOSE_DOCUMENTS_PREP_ID = 1230 | |
Public Const RID_STR_ENG_DOCUMENTS_CHOOSE_DOC_TYPES_PREP_ID = 1236 | |
Public Const RID_STR_ENG_DOCUMENTS_INCLUDE_SUBDIRECTORIES_PREP_ID = 1232 | |
Public Const RID_STR_IGNORE_OLDER_CB_ID = 1231 | |
Public Const RID_STR_IGNORE_OLDER_3_MONTHS_ID = 1233 | |
Public Const RID_STR_IGNORE_OLDER_6_MONTHS_ID = 1234 | |
Public Const RID_STR_IGNORE_OLDER_12_MONTHS_ID = 1235 | |
Public Const RID_STR_ENG_RESULTS_CHOOSE_OPTIONS_PREP_ID = 1330 | |
Public Const RID_STR_ENG_RESULTS_ANALYSIS_XLS_PREP_ID = 1332 | |
Public Const RID_STR_ENG_ANALYZE_NUM_DOCS_PREP_ID = 1431 | |
Public Const RID_STR_ENG_ANALYZE_SETUP_COMPLETE_PREP_ID = 1430 | |
Public Const RID_STR_ENG_ANALYZE_IGNORED_DOCS_ID = 1435 | |
Public Const RID_STR_ENG_ANALYZE_START_ID = 1413 | |
Public Const RID_STR_ENG_ANALYZE_COMPLETED_ID = 1412 | |
Public Const RID_STR_ENG_ANALYZE_VIEW_NOW_ID = 1414 | |
Public Const RID_STR_ENG_ANALYZE_VIEW_LATER_ID = 1415 | |
Public Const RID_STR_ENG_ANALYSE_NOT_RUN = 1416 | |
Public Const RID_STR_ENG_OTHER_PLEASE_REFER_TO_README_PREP_ID = 1838 | |
Public Const RID_STR_ENG_OTHER_XML_RESULTS_PREP_ID = 1845 | |
Public Const RID_STR_ENG_OTHER_PREPARE_PROMPT_PREP_ID = 1846 | |
Public Const RID_STR_ENG_OTHER_PREPARE_COMPLETED_PREP_ID = 1847 | |
'Resource Strings Codes | |
' NOTE: to make a resource the default it must be the first string table inserted | |
' in the resource table - if it is not, just create several new string tables and | |
' copy what you want as default into the first new one you create, copy the others | |
' then delete the originals. | |
' | |
' To provide same string table for all English variants or all German variants | |
' I have added code to set LANG_BASE_ID dependent on current locale | |
' Refer to p.414 VBA in a Nutshell, Lomax | |
' I now have a single string table with each lang variant suitably offset: | |
' New locale - increase ofsets by 1000 - refer to DocAnalysisWizard.rc | |
' | |
' English - eng - Start at 1000 | |
' German - ger - Start at 2000 | |
' BrazilianPortugese - por - Start at 4000 | |
' French - fre - Start at 5000 | |
' Italian - ita - Start at 6000 | |
' Spanish - spa - Start at 7000 | |
' Swedish - swe - Start at 8000 | |
' String ID's must match those in DocAnalysisWizard.rc | |
Const LANG_BASE_ID = 1000 | |
Const INTERNAL_RESOURCE_BASE_ID = LANG_BASE_ID + 800 | |
' Setup Doc Preparation specific strings | |
#If PREPARATION Then | |
Global Const gBoolPreparation = True | |
Public Const TITLE_ID = RID_STR_ENG_TITLE_PREP_ID | |
Public Const CHK_SUBDIRS_ID = RID_STR_ENG_DOCUMENTS_INCLUDE_SUBDIRECTORIES_PREP_ID | |
Public Const SETUP_ANALYSIS_XLS_ID = RID_STR_ENG_RESULTS_ANALYSIS_XLS_PREP_ID | |
Public Const ANALYZE_TOTAL_NUM_DOCS_ID = RID_STR_ENG_ANALYZE_NUM_DOCS_PREP_ID | |
Public Const XML_RESULTS_ID = RID_STR_ENG_OTHER_XML_RESULTS_PREP_ID | |
#Else | |
Global Const gBoolPreparation = False | |
Public Const TITLE_ID = LANG_BASE_ID + 0 | |
Public Const CHK_SUBDIRS_ID = LANG_BASE_ID + 202 | |
Public Const SETUP_ANALYSIS_XLS_ID = LANG_BASE_ID + 302 | |
Public Const ANALYZE_TOTAL_NUM_DOCS_ID = LANG_BASE_ID + 401 | |
Public Const XML_RESULTS_ID = INTERNAL_RESOURCE_BASE_ID + 15 | |
#End If | |
Public Const PRODUCTNAME_ID = LANG_BASE_ID + 1 | |
Public Const LBL_STEPS_ID = LANG_BASE_ID + 40 | |
Public Const INTRO1_ID = LANG_BASE_ID + 101 | |
Public Const ANALYZE_DOCUMENTS_ID = LANG_BASE_ID + 402 | |
Public Const ANALYZE_TEMPLATES_ID = LANG_BASE_ID + 403 | |
Public Const ANALYZE_DOCUMENTS_XLS_ID = LANG_BASE_ID + 408 | |
Public Const ANALYZE_DOCUMENTS_PPT_ID = LANG_BASE_ID + 409 | |
Public Const RUNBTN_START_ID = LANG_BASE_ID + 404 | |
Public Const PREPAREBTN_START_ID = LANG_BASE_ID + 411 | |
Public Const README_FILE_ID = INTERNAL_RESOURCE_BASE_ID + 5 'Readme.doc | |
Public Const BROWSE_FOR_DOC_DIR_ID = INTERNAL_RESOURCE_BASE_ID + 6 | |
Public Const BROWSE_FOR_RES_DIR_ID = INTERNAL_RESOURCE_BASE_ID + 7 | |
Public Const RUNBTN_RUNNING_ID = INTERNAL_RESOURCE_BASE_ID + 10 | |
Public Const PROGRESS_CAPTION = INTERNAL_RESOURCE_BASE_ID + 20 | |
Public Const PROGRESS_ABORTING = INTERNAL_RESOURCE_BASE_ID + 21 | |
Public Const PROGRESS_PATH_LABEL = INTERNAL_RESOURCE_BASE_ID + 22 | |
Public Const PROGRESS_FILE_LABEL = INTERNAL_RESOURCE_BASE_ID + 23 | |
Public Const PROGRESS_INFO_LABEL = INTERNAL_RESOURCE_BASE_ID + 24 | |
Public Const PROGRESS_WAIT_LABEL = INTERNAL_RESOURCE_BASE_ID + 25 | |
Public Const SEARCH_PATH_LABEL = PROGRESS_PATH_LABEL | |
Public Const SEARCH_CAPTION = INTERNAL_RESOURCE_BASE_ID + 26 | |
Public Const SEARCH_INFO_LABEL = INTERNAL_RESOURCE_BASE_ID + 27 | |
Public Const SEARCH_FOUND_LABEL = INTERNAL_RESOURCE_BASE_ID + 28 | |
Public Const TERMINATE_CAPTION = INTERNAL_RESOURCE_BASE_ID + 30 | |
Public Const TERMINATE_INFO = INTERNAL_RESOURCE_BASE_ID + 31 | |
Public Const TERMINATE_YES = INTERNAL_RESOURCE_BASE_ID + 32 | |
Public Const TERMINATE_NO = INTERNAL_RESOURCE_BASE_ID + 33 | |
'Error Resource Strings Codes | |
Const ERROR_BASE_ID = LANG_BASE_ID + 900 | |
Public Const ERR_MISSING_RESULTS_DOC = ERROR_BASE_ID + 0 | |
Public Const ERR_NO_DOC_DIR = ERROR_BASE_ID + 1 | |
Public Const ERR_NO_DOC_TYPES = ERROR_BASE_ID + 2 | |
Public Const ERR_NO_RES_DIR = ERROR_BASE_ID + 3 | |
Public Const ERR_CREATE_DIR = ERROR_BASE_ID + 4 | |
Public Const ERR_MISSING_RESULTS_TEMPLATE = ERROR_BASE_ID + 5 | |
Public Const ERR_MISSING_EXCEL_DRIVER = ERROR_BASE_ID + 6 | |
Public Const ERR_EXCEL_DRIVER_CRASH = ERROR_BASE_ID + 7 | |
Public Const ERR_MISSING_WORD_DRIVER = ERROR_BASE_ID + 8 | |
Public Const ERR_WORD_DRIVER_CRASH = ERROR_BASE_ID + 9 | |
Public Const ERR_MISSING_README = ERROR_BASE_ID + 10 | |
Public Const ERR_MISSING_PP_DRIVER = ERROR_BASE_ID + 11 | |
Public Const ERR_PP_DRIVER_CRASH = ERROR_BASE_ID + 12 | |
Public Const ERR_SUPPORTED_VERSION = ERROR_BASE_ID + 13 | |
Public Const ERR_ISSUES_VERSION_MISMATCH = ERROR_BASE_ID + 14 | |
Public Const ERR_ISSUES_LIST_MISSING = ERROR_BASE_ID + 15 | |
Public Const ERR_SUPPORTED_OSVERSION = ERROR_BASE_ID + 16 | |
Public Const ERR_OPEN_RESULTS_SPREADSHEET = ERROR_BASE_ID + 17 | |
Public Const ERR_EXCEL_OPEN = ERROR_BASE_ID + 18 | |
Public Const ERR_NO_ACCESS_TO_VBPROJECT = ERROR_BASE_ID + 19 | |
Public Const ERR_AUTOMATION_FAILURE = ERROR_BASE_ID + 20 | |
Public Const ERR_NO_RESULTS_DIRECTORY = ERROR_BASE_ID + 21 | |
Public Const ERR_CREATE_FILE = ERROR_BASE_ID + 22 | |
Public Const ERR_XML_RESULTS_ONLY = ERROR_BASE_ID + 23 | |
Public Const ERR_NOT_INSTALLED = ERROR_BASE_ID + 24 | |
Public Const ERR_CDROM_NOT_ALLOWED = ERROR_BASE_ID + 25 | |
Public Const ERR_CDROM_NOT_READY = ERROR_BASE_ID + 26 | |
Public Const ERR_NO_WRITE_TO_READ_ONLY_FOLDER = ERROR_BASE_ID + 27 | |
Public Const ERR_APPLICATION_IN_USE = ERROR_BASE_ID + 28 | |
Public Const ERR_MISSING_IMPORTANT_FILE = ERROR_BASE_ID + 29 | |
Private Const LOCALE_ILANGUAGE As Long = &H1 'language id | |
Private Const LOCALE_SLANGUAGE As Long = &H2 'localized name of language | |
Private Const LOCALE_SENGLANGUAGE As Long = &H1001 'English name of language | |
Private Const LOCALE_SABBREVLANGNAME As Long = &H3 'abbreviated language name | |
Private Const LOCALE_SCOUNTRY As Long = &H6 'localized name of country | |
Private Const LOCALE_SENGCOUNTRY As Long = &H1002 'English name of country | |
Private Const LOCALE_SABBREVCTRYNAME As Long = &H7 'abbreviated country name | |
Private Const LOCALE_SISO639LANGNAME As Long = &H59 'ISO abbreviated language name | |
Private Const LOCALE_SISO3166CTRYNAME As Long = &H5A 'ISO abbreviated country name | |
Private Const LOCALE_JAPAN As Long = &H411 | |
Private Const LOCALE_KOREA As Long = &H412 | |
Private Const LOCALE_ZH_CN As Long = &H404 | |
Private Const LOCALE_ZH_TW As Long = &H804 | |
Private Const RES_PREFIX = ".\Resources\Resources.dll" | |
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 | |
Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal fileName$) | |
Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long | |
Private Declare Function LoadString Lib "user32" Alias "LoadStringA" _ | |
(ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, _ | |
ByVal nBufferMax As Long) As Long | |
'WinHelp Commands | |
'Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long | |
'Public Const HELP_QUIT = &H2 ' Terminate help | |
'Public Const HELP_CONTENTS = &H3& ' Display index/contents | |
'Public Const HELP_CONTEXT = &H1 ' Display topic in ulTopic | |
'Public Const HELP_INDEX = &H3 ' Display index | |
Public Const CBASE_RESOURCE_DIR = ".\resources" | |
Private mStrTrue As String | |
Private mLocaleDir As String | |
Private ghInst As Long | |
Function getLocaleDir() As String | |
If mLocaleDir = "" Then | |
getLocaleLangBaseIDandSetLocaleDir | |
End If | |
getLocaleDir = mLocaleDir | |
End Function | |
Public Function GetLocaleLanguage() As String | |
Dim lReturn As Long | |
Dim lLocID As Long | |
Dim sData As String | |
Dim lDataLen As Long | |
lDataLen = 0 | |
lReturn = GetLocaleInfo(lLocID, LOCALE_SENGLANGUAGE, sData, lDataLen) | |
sData = String(lReturn, 0) & vbNullChar | |
lDataLen = lReturn | |
lReturn = GetLocaleInfo(lLocID, LOCALE_SENGLANGUAGE, sData, lDataLen) | |
End Function | |
Function getLocaleLangBaseIDandSetLocaleDir() As Integer | |
On Error GoTo HandleErrors | |
Dim currentFunctionName As String | |
currentFunctionName = "getLocaleLangBaseIDandSetLocaleDir" | |
Dim baseID As Long | |
Dim bUseLocale As Boolean | |
Dim fso As FileSystemObject | |
Set fso = New FileSystemObject | |
Dim isoLangStr As String | |
Dim isoCountryStr As String | |
Dim langStr As String | |
Dim userLCID As Long | |
userLCID = GetUserDefaultLCID() | |
Dim sysLCID As Long | |
sysLCID = GetSystemDefaultLCID() | |
isoLangStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO639LANGNAME) | |
isoCountryStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO3166CTRYNAME) | |
langStr = GetUserLocaleInfo(sysLCID, LOCALE_SENGLANGUAGE) | |
baseID = 0 | |
mLocaleDir = "" | |
If fso.FileExists(fso.GetAbsolutePathName("debug.ini")) Then | |
Dim overrideLangStr As String | |
overrideLangStr = ProfileGetItem("debug", "langoverride", "", fso.GetAbsolutePathName("debug.ini")) | |
If overrideLangStr <> "" Then | |
Debug.Print "Overriding language " & isoLangStr & " with " & overrideLangStr & "\n" | |
isoLangStr = overrideLangStr | |
End If | |
End If | |
'check for locale dirs in following order: | |
' CBASE_RESOURCE_DIR & "\" & isoLangStr | |
' CBASE_RESOURCE_DIR & "\" & isoLangStr & "-" & isoCountryStr | |
' CBASE_RESOURCE_DIR & "\" & "eng" | |
'If fso.FolderExists(fso.GetAbsolutePathName(CBASE_RESOURCE_DIR & "\" & isoLangStr)) Then | |
' mLocaleDir = CBASE_RESOURCE_DIR & "\" & isoLangStr | |
' baseID = getBaseID(isoLangStr) | |
'ElseIf fso.FolderExists(fso.GetAbsolutePathName(CBASE_RESOURCE_DIR & "\" & isoLangStr & "-" & isoCountryStr)) Then | |
' mLocaleDir = CBASE_RESOURCE_DIR & "\" & isoLangStr & "-" & isoCountryStr | |
' baseID = getBaseID(isoLangStr & "-" & isoCountryStr) | |
'Else | |
mLocaleDir = CBASE_RESOURCE_DIR | |
baseID = 1000 | |
'End If | |
getLocaleLangBaseIDandSetLocaleDir = CInt(baseID) | |
FinalExit: | |
Set fso = Nothing | |
Exit Function | |
HandleErrors: | |
Debug.Print currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
Resume FinalExit | |
End Function | |
'-------------------------------------------------------------------------- | |
'this sub must be executed from the immediate window | |
'it will add the entry to VBADDIN.INI if it doesn't already exist | |
'so that the add-in is on available next time VB is loaded | |
'-------------------------------------------------------------------------- | |
Sub AddToINI() | |
Debug.Print WritePrivateProfileString("Add-Ins32", WIZARD_NAME & ".Wizard", "0", "VBADDIN.INI") | |
End Sub | |
Function GetResString(nRes As Integer) As String | |
Dim sTmp As String | |
Dim sRes As String * 1024 | |
Dim sRetStr As String | |
Dim nRet As Long | |
Do | |
'sTmp = LoadResString(nRes) | |
nRet = LoadString(ghInst, nRes, sRes, 1024) | |
sTmp = Left$(sRes, nRet) | |
If Right(sTmp, 1) = "_" Then | |
sRetStr = sRetStr + VBA.Left(sTmp, Len(sTmp) - 1) | |
Else | |
sRetStr = sRetStr + sTmp | |
End If | |
nRes = nRes + 1 | |
Loop Until Right(sTmp, 1) <> "_" | |
GetResString = sRetStr | |
End Function | |
Function GetField(sBuffer As String, sSep As String) As String | |
Dim p As Integer | |
p = InStr(sBuffer & sSep, sSep) | |
GetField = VBA.Left(sBuffer, p - 1) | |
sBuffer = Mid(sBuffer, p + Len(sSep)) | |
End Function | |
' Parts of the following code are from: | |
' http://support.microsoft.com/default.aspx?scid=kb;en-us;232625&Product=vb6 | |
Private Function GetCharSet(sCdpg As String) As Integer | |
Select Case sCdpg | |
Case "932" ' Japanese | |
GetCharSet = 128 | |
Case "936" ' Simplified Chinese | |
GetCharSet = 134 | |
Case "949" ' Korean | |
GetCharSet = 129 | |
Case "950" ' Traditional Chinese | |
GetCharSet = 136 | |
Case "1250" ' Eastern Europe | |
GetCharSet = 238 | |
Case "1251" ' Russian | |
GetCharSet = 204 | |
Case "1252" ' Western European Languages | |
GetCharSet = 0 | |
Case "1253" ' Greek | |
GetCharSet = 161 | |
Case "1254" ' Turkish | |
GetCharSet = 162 | |
Case "1255" ' Hebrew | |
GetCharSet = 177 | |
Case "1256" ' Arabic | |
GetCharSet = 178 | |
Case "1257" ' Baltic | |
GetCharSet = 186 | |
Case Else | |
GetCharSet = 0 | |
End Select | |
End Function | |
Private Function StripNullTerminator(sCP As String) | |
Dim posNull As Long | |
posNull = InStr(sCP, Chr$(0)) | |
StripNullTerminator = Left$(sCP, posNull - 1) | |
End Function | |
Private Function GetResourceDataFileName() As String | |
On Error GoTo HandleErrors | |
Dim currentFunctionName As String | |
currentFunctionName = "GetResourceDataFileName" | |
Dim fileName As String | |
Dim fso As FileSystemObject | |
Set fso = New FileSystemObject | |
GetResourceDataFileName = fso.GetAbsolutePathName(RES_PREFIX) | |
GoTo FinalExit | |
' use the following code when we have one resource file for each language | |
Dim isoLangStr As String | |
Dim isoCountryStr As String | |
Dim userLCID As Long | |
userLCID = GetUserDefaultLangID() | |
Dim sysLCID As Long | |
sysLCID = GetSystemDefaultLangID() | |
isoLangStr = GetUserLocaleInfo(userLCID, LOCALE_SISO639LANGNAME) | |
isoCountryStr = GetUserLocaleInfo(userLCID, LOCALE_SISO3166CTRYNAME) | |
'check for locale data in following order: | |
' user language | |
' isoLangStr & "_" & isoCountryStr & ".dll" | |
' isoLangStr & ".dll" | |
' system language | |
' isoLangStr & "_" & isoCountryStr & ".dll" | |
' isoLangStr & ".dll" | |
' "en_US" & ".dll" | |
fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & "-" & isoCountryStr & ".dll") | |
If fso.FileExists(fileName) Then | |
GetResourceDataFileName = fileName | |
Else | |
fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & ".dll") | |
If fso.FileExists(fileName) Then | |
GetResourceDataFileName = fileName | |
Else | |
isoLangStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO639LANGNAME) | |
isoCountryStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO3166CTRYNAME) | |
fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & "-" & isoCountryStr & ".dll") | |
If fso.FileExists(fileName) Then | |
GetResourceDataFileName = fileName | |
Else | |
fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & ".dll") | |
If fso.FileExists(fileName) Then | |
GetResourceDataFileName = fileName | |
Else | |
GetResourceDataFileName = fso.GetAbsolutePathName(RES_PREFIX & "en-US.dll") | |
End If | |
End If | |
End If | |
End If | |
FinalExit: | |
Set fso = Nothing | |
Exit Function | |
HandleErrors: | |
WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
Resume FinalExit | |
End Function | |
Sub LoadResStrings(frm As Form) | |
Dim ctl As Control | |
Dim obj As Object | |
Dim LCID As Long, X As Long | |
Dim sCodePage As String | |
Dim nCharSet As Integer | |
Dim currentFunctionName As String | |
currentFunctionName = "LoadResStrings" | |
On Error GoTo HandleErrors | |
ghInst = LoadLibrary(GetResourceDataFileName()) | |
On Error Resume Next | |
sCodePage = String$(16, " ") | |
LCID = GetThreadLocale() 'Get Current locale | |
X = GetLocaleInfo(LCID, LOCALE_IDEFAULTANSICODEPAGE, _ | |
sCodePage, Len(sCodePage)) 'Get code page | |
sCodePage = StripNullTerminator(sCodePage) | |
nCharSet = GetCharSet(sCodePage) 'Convert code page to charset | |
'set the form's caption | |
If IsNumeric(frm.Tag) Then | |
frm.Caption = LoadResString(CInt(frm.Tag)) | |
End If | |
'set the controls' captions using the caption | |
'property for menu items and the Tag property | |
'for all other controls | |
For Each ctl In frm.Controls | |
Err = 0 | |
If (nCharSet <> 0) Then | |
ctl.Font.Charset = nCharSet | |
End If | |
If TypeName(ctl) = "Menu" Then | |
If IsNumeric(ctl.Caption) Then | |
ctl.Caption = LoadResString(CInt(ctl.Caption)) | |
End If | |
ElseIf TypeName(ctl) = "TabStrip" Then | |
For Each obj In ctl.Tabs | |
If IsNumeric(obj.Tag) Then | |
obj.Caption = LoadResString(CInt(obj.Tag)) | |
End If | |
'check for a tooltip | |
If IsNumeric(obj.ToolTipText) Then | |
If Err = 0 Then | |
obj.ToolTipText = LoadResString(CInt(obj.ToolTipText)) | |
End If | |
End If | |
Next | |
ElseIf TypeName(ctl) = "Toolbar" Then | |
For Each obj In ctl.Buttons | |
If IsNumeric(obj.Tag) Then | |
obj.ToolTipText = LoadResString(CInt(obj.Tag)) | |
End If | |
Next | |
ElseIf TypeName(ctl) = "ListView" Then | |
For Each obj In ctl.ColumnHeaders | |
If IsNumeric(obj.Tag) Then | |
obj.Text = LoadResString(CInt(obj.Tag)) | |
End If | |
Next | |
ElseIf TypeName(ctl) = "TextBox" Then | |
If IsNumeric(ctl.Tag) Then | |
ctl.Text = LoadResString(CInt(ctl.Tag)) | |
End If | |
Else | |
If IsNumeric(ctl.Tag) Then | |
ctl.Caption = GetResString(CInt(ctl.Tag)) | |
End If | |
'check for a tooltip | |
If IsNumeric(ctl.ToolTipText) Then | |
If Err = 0 Then | |
ctl.ToolTipText = LoadResString(CInt(ctl.ToolTipText)) | |
End If | |
End If | |
End If | |
Next | |
FinalExit: | |
Exit Sub | |
HandleErrors: | |
WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source | |
Resume FinalExit | |
End Sub | |
'================================================== | |
'Purpose: Replace the sToken string(s) in | |
' res file string for correct placement | |
' of localized tokens | |
' | |
'Inputs: sString = String to search and replace in | |
' sToken = token to replace | |
' sReplacement = String to replace token with | |
' | |
'Outputs: New string with token replaced throughout | |
'================================================== | |
Function ReplaceTopicTokens(sString As String, _ | |
sToken As String, _ | |
sReplacement As String) As String | |
On Error Resume Next | |
Dim p As Integer | |
Dim sTmp As String | |
sTmp = sString | |
Do | |
p = InStr(sTmp, sToken) | |
If p Then | |
sTmp = VBA.Left(sTmp, p - 1) + sReplacement + Mid(sTmp, p + Len(sToken)) | |
End If | |
Loop While p | |
ReplaceTopicTokens = sTmp | |
End Function | |
'================================================== | |
'Purpose: Replace the sToken1 and sToken2 strings in | |
' res file string for correct placement | |
' of localized tokens | |
' | |
'Inputs: sString = String to search and replace in | |
' sToken1 = 1st token to replace | |
' sReplacement1 = 1st String to replace token with | |
' sToken2 = 2nd token to replace | |
' sReplacement2 = 2nd String to replace token with | |
' | |
'Outputs: New string with token replaced throughout | |
'================================================== | |
Function ReplaceTopic2Tokens(sString As String, _ | |
sToken1 As String, _ | |
sReplacement1 As String, _ | |
sToken2 As String, _ | |
sReplacement2 As String) As String | |
On Error Resume Next | |
ReplaceTopic2Tokens = _ | |
ReplaceTopicTokens(ReplaceTopicTokens(sString, sToken1, sReplacement1), _ | |
sToken2, sReplacement2) | |
End Function | |
Public Function GetResData(sResName As String, sResType As String) As String | |
Dim sTemp As String | |
Dim p As Integer | |
sTemp = StrConv(LoadResData(sResName, sResType), vbUnicode) | |
p = InStr(sTemp, vbNullChar) | |
If p Then sTemp = VBA.Left$(sTemp, p - 1) | |
GetResData = sTemp | |
End Function | |
Function AddToAddInCommandBar(VBInst As Object, sCaption As String, oBitmap As Object) As Object 'Office.CommandBarControl | |
On Error GoTo AddToAddInCommandBarErr | |
Dim c As Integer | |
Dim cbMenuCommandBar As Object 'Office.CommandBarControl 'command bar object | |
Dim cbMenu As Object | |
'see if we can find the Add-Ins menu | |
Set cbMenu = VBInst.CommandBars("Add-Ins") | |
If cbMenu Is Nothing Then | |
'not available so we fail | |
Exit Function | |
End If | |
'add it to the command bar | |
Set cbMenuCommandBar = cbMenu.Controls.add(1) | |
c = cbMenu.Controls.count - 1 | |
If cbMenu.Controls(c).BeginGroup And _ | |
Not cbMenu.Controls(c - 1).BeginGroup Then | |
'this s the first addin being added so it needs a separator | |
cbMenuCommandBar.BeginGroup = True | |
End If | |
'set the caption | |
cbMenuCommandBar.Caption = sCaption | |
'undone:set the onaction (required at this point) | |
cbMenuCommandBar.OnAction = "hello" | |
'copy the icon to the clipboard | |
Clipboard.SetData oBitmap | |
'set the icon for the button | |
cbMenuCommandBar.PasteFace | |
Set AddToAddInCommandBar = cbMenuCommandBar | |
Exit Function | |
AddToAddInCommandBarErr: | |
End Function | |