1Attribute VB_Name = "modWizard" 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 24Global Const WIZARD_NAME = "Analysis" 25 26'Implementation details - not required for localisation 27Public Const CWORD_DRIVER_FILE = "_OOoDocAnalysisWordDriver.doc" 28Public Const CEXCEL_DRIVER_FILE = "_OOoDocAnalysisExcelDriver.xls" 29Public Const CPP_DRIVER_FILE = "_OOoDocAnalysisPPTDriver.ppt" 30Public Const CRESULTS_TEMPLATE_FILE = "results.xlt" 31Public Const CISSUES_LIST_FILE = "issues.list" 32Public Const CANALYSIS_INI_FILE = "analysis.ini" 33Public Const CLAUNCH_DRIVERS_EXE = "LaunchDrivers.exe" 34Public Const CMSO_KILL_EXE = "msokill.exe" 35Public Const CRESOURCE_DLL = "Resources.dll" 36 37' Preparation String ID's from DocAnalysisWizard.rc 38Public Const RID_STR_ENG_TITLE_PREP_ID = 1030 39Public Const RID_STR_ENG_SIDEBAR_ANALYZE_PREP_ID = 1074 40 41Public Const RID_STR_ENG_INTRODUCTION_INTRO1_PREP_ID = 1131 42Public Const RID_STR_ENG_INTRODUCTION_INTRO2_PREP_ID = 1132 43Public Const RID_STR_ENG_INTRODUCTION_INTRO3_PREP_ID = 1134 44 45Public Const RID_STR_ENG_DOCUMENTS_CHOOSE_DOCUMENTS_PREP_ID = 1230 46Public Const RID_STR_ENG_DOCUMENTS_CHOOSE_DOC_TYPES_PREP_ID = 1236 47Public Const RID_STR_ENG_DOCUMENTS_INCLUDE_SUBDIRECTORIES_PREP_ID = 1232 48 49Public Const RID_STR_IGNORE_OLDER_CB_ID = 1231 50Public Const RID_STR_IGNORE_OLDER_3_MONTHS_ID = 1233 51Public Const RID_STR_IGNORE_OLDER_6_MONTHS_ID = 1234 52Public Const RID_STR_IGNORE_OLDER_12_MONTHS_ID = 1235 53 54Public Const RID_STR_ENG_RESULTS_CHOOSE_OPTIONS_PREP_ID = 1330 55Public Const RID_STR_ENG_RESULTS_ANALYSIS_XLS_PREP_ID = 1332 56 57Public Const RID_STR_ENG_ANALYZE_NUM_DOCS_PREP_ID = 1431 58Public Const RID_STR_ENG_ANALYZE_SETUP_COMPLETE_PREP_ID = 1430 59Public Const RID_STR_ENG_ANALYZE_IGNORED_DOCS_ID = 1435 60Public Const RID_STR_ENG_ANALYZE_START_ID = 1413 61Public Const RID_STR_ENG_ANALYZE_COMPLETED_ID = 1412 62Public Const RID_STR_ENG_ANALYZE_VIEW_NOW_ID = 1414 63Public Const RID_STR_ENG_ANALYZE_VIEW_LATER_ID = 1415 64Public Const RID_STR_ENG_ANALYSE_NOT_RUN = 1416 65 66Public Const RID_STR_ENG_OTHER_PLEASE_REFER_TO_README_PREP_ID = 1838 67Public Const RID_STR_ENG_OTHER_XML_RESULTS_PREP_ID = 1845 68Public Const RID_STR_ENG_OTHER_PREPARE_PROMPT_PREP_ID = 1846 69Public Const RID_STR_ENG_OTHER_PREPARE_COMPLETED_PREP_ID = 1847 70 71'Resource Strings Codes 72' NOTE: to make a resource the default it must be the first string table inserted 73' in the resource table - if it is not, just create several new string tables and 74' copy what you want as default into the first new one you create, copy the others 75' then delete the originals. 76' 77' To provide same string table for all English variants or all German variants 78' I have added code to set LANG_BASE_ID dependent on current locale 79' Refer to p.414 VBA in a Nutshell, Lomax 80' I now have a single string table with each lang variant suitably offset: 81' New locale - increase ofsets by 1000 - refer to DocAnalysisWizard.rc 82' 83' English - eng - Start at 1000 84' German - ger - Start at 2000 85' BrazilianPortugese - por - Start at 4000 86' French - fre - Start at 5000 87' Italian - ita - Start at 6000 88' Spanish - spa - Start at 7000 89' Swedish - swe - Start at 8000 90 91 92' String ID's must match those in DocAnalysisWizard.rc 93Const LANG_BASE_ID = 1000 94Const INTERNAL_RESOURCE_BASE_ID = LANG_BASE_ID + 800 95 96' Setup Doc Preparation specific strings 97#If PREPARATION Then 98Global Const gBoolPreparation = True 99 100Public Const TITLE_ID = RID_STR_ENG_TITLE_PREP_ID 101Public Const CHK_SUBDIRS_ID = RID_STR_ENG_DOCUMENTS_INCLUDE_SUBDIRECTORIES_PREP_ID 102Public Const SETUP_ANALYSIS_XLS_ID = RID_STR_ENG_RESULTS_ANALYSIS_XLS_PREP_ID 103Public Const ANALYZE_TOTAL_NUM_DOCS_ID = RID_STR_ENG_ANALYZE_NUM_DOCS_PREP_ID 104Public Const XML_RESULTS_ID = RID_STR_ENG_OTHER_XML_RESULTS_PREP_ID 105 106#Else 107Global Const gBoolPreparation = False 108 109Public Const TITLE_ID = LANG_BASE_ID + 0 110Public Const CHK_SUBDIRS_ID = LANG_BASE_ID + 202 111Public Const SETUP_ANALYSIS_XLS_ID = LANG_BASE_ID + 302 112Public Const ANALYZE_TOTAL_NUM_DOCS_ID = LANG_BASE_ID + 401 113Public Const XML_RESULTS_ID = INTERNAL_RESOURCE_BASE_ID + 15 114#End If 115 116Public Const PRODUCTNAME_ID = LANG_BASE_ID + 1 117Public Const LBL_STEPS_ID = LANG_BASE_ID + 40 118Public Const INTRO1_ID = LANG_BASE_ID + 101 119 120Public Const ANALYZE_DOCUMENTS_ID = LANG_BASE_ID + 402 121Public Const ANALYZE_TEMPLATES_ID = LANG_BASE_ID + 403 122Public Const ANALYZE_DOCUMENTS_XLS_ID = LANG_BASE_ID + 408 123Public Const ANALYZE_DOCUMENTS_PPT_ID = LANG_BASE_ID + 409 124Public Const RUNBTN_START_ID = LANG_BASE_ID + 404 125Public Const PREPAREBTN_START_ID = LANG_BASE_ID + 411 126 127Public Const README_FILE_ID = INTERNAL_RESOURCE_BASE_ID + 5 'Readme.doc 128Public Const BROWSE_FOR_DOC_DIR_ID = INTERNAL_RESOURCE_BASE_ID + 6 129Public Const BROWSE_FOR_RES_DIR_ID = INTERNAL_RESOURCE_BASE_ID + 7 130Public Const RUNBTN_RUNNING_ID = INTERNAL_RESOURCE_BASE_ID + 10 131 132Public Const PROGRESS_CAPTION = INTERNAL_RESOURCE_BASE_ID + 20 133Public Const PROGRESS_ABORTING = INTERNAL_RESOURCE_BASE_ID + 21 134Public Const PROGRESS_PATH_LABEL = INTERNAL_RESOURCE_BASE_ID + 22 135Public Const PROGRESS_FILE_LABEL = INTERNAL_RESOURCE_BASE_ID + 23 136Public Const PROGRESS_INFO_LABEL = INTERNAL_RESOURCE_BASE_ID + 24 137Public Const PROGRESS_WAIT_LABEL = INTERNAL_RESOURCE_BASE_ID + 25 138 139Public Const SEARCH_PATH_LABEL = PROGRESS_PATH_LABEL 140Public Const SEARCH_CAPTION = INTERNAL_RESOURCE_BASE_ID + 26 141Public Const SEARCH_INFO_LABEL = INTERNAL_RESOURCE_BASE_ID + 27 142Public Const SEARCH_FOUND_LABEL = INTERNAL_RESOURCE_BASE_ID + 28 143 144Public Const TERMINATE_CAPTION = INTERNAL_RESOURCE_BASE_ID + 30 145Public Const TERMINATE_INFO = INTERNAL_RESOURCE_BASE_ID + 31 146Public Const TERMINATE_YES = INTERNAL_RESOURCE_BASE_ID + 32 147Public Const TERMINATE_NO = INTERNAL_RESOURCE_BASE_ID + 33 148 149'Error Resource Strings Codes 150Const ERROR_BASE_ID = LANG_BASE_ID + 900 151Public Const ERR_MISSING_RESULTS_DOC = ERROR_BASE_ID + 0 152Public Const ERR_NO_DOC_DIR = ERROR_BASE_ID + 1 153Public Const ERR_NO_DOC_TYPES = ERROR_BASE_ID + 2 154Public Const ERR_NO_RES_DIR = ERROR_BASE_ID + 3 155Public Const ERR_CREATE_DIR = ERROR_BASE_ID + 4 156Public Const ERR_MISSING_RESULTS_TEMPLATE = ERROR_BASE_ID + 5 157Public Const ERR_MISSING_EXCEL_DRIVER = ERROR_BASE_ID + 6 158Public Const ERR_EXCEL_DRIVER_CRASH = ERROR_BASE_ID + 7 159Public Const ERR_MISSING_WORD_DRIVER = ERROR_BASE_ID + 8 160Public Const ERR_WORD_DRIVER_CRASH = ERROR_BASE_ID + 9 161Public Const ERR_MISSING_README = ERROR_BASE_ID + 10 162Public Const ERR_MISSING_PP_DRIVER = ERROR_BASE_ID + 11 163Public Const ERR_PP_DRIVER_CRASH = ERROR_BASE_ID + 12 164Public Const ERR_SUPPORTED_VERSION = ERROR_BASE_ID + 13 165Public Const ERR_ISSUES_VERSION_MISMATCH = ERROR_BASE_ID + 14 166Public Const ERR_ISSUES_LIST_MISSING = ERROR_BASE_ID + 15 167Public Const ERR_SUPPORTED_OSVERSION = ERROR_BASE_ID + 16 168Public Const ERR_OPEN_RESULTS_SPREADSHEET = ERROR_BASE_ID + 17 169Public Const ERR_EXCEL_OPEN = ERROR_BASE_ID + 18 170Public Const ERR_NO_ACCESS_TO_VBPROJECT = ERROR_BASE_ID + 19 171Public Const ERR_AUTOMATION_FAILURE = ERROR_BASE_ID + 20 172Public Const ERR_NO_RESULTS_DIRECTORY = ERROR_BASE_ID + 21 173Public Const ERR_CREATE_FILE = ERROR_BASE_ID + 22 174Public Const ERR_XML_RESULTS_ONLY = ERROR_BASE_ID + 23 175Public Const ERR_NOT_INSTALLED = ERROR_BASE_ID + 24 176Public Const ERR_CDROM_NOT_ALLOWED = ERROR_BASE_ID + 25 177Public Const ERR_CDROM_NOT_READY = ERROR_BASE_ID + 26 178Public Const ERR_NO_WRITE_TO_READ_ONLY_FOLDER = ERROR_BASE_ID + 27 179Public Const ERR_APPLICATION_IN_USE = ERROR_BASE_ID + 28 180Public Const ERR_MISSING_IMPORTANT_FILE = ERROR_BASE_ID + 29 181 182 183Private Const LOCALE_ILANGUAGE As Long = &H1 'language id 184Private Const LOCALE_SLANGUAGE As Long = &H2 'localized name of language 185Private Const LOCALE_SENGLANGUAGE As Long = &H1001 'English name of language 186Private Const LOCALE_SABBREVLANGNAME As Long = &H3 'abbreviated language name 187Private Const LOCALE_SCOUNTRY As Long = &H6 'localized name of country 188Private Const LOCALE_SENGCOUNTRY As Long = &H1002 'English name of country 189Private Const LOCALE_SABBREVCTRYNAME As Long = &H7 'abbreviated country name 190Private Const LOCALE_SISO639LANGNAME As Long = &H59 'ISO abbreviated language name 191Private Const LOCALE_SISO3166CTRYNAME As Long = &H5A 'ISO abbreviated country name 192 193Private Const LOCALE_JAPAN As Long = &H411 194Private Const LOCALE_KOREA As Long = &H412 195Private Const LOCALE_ZH_CN As Long = &H404 196Private Const LOCALE_ZH_TW As Long = &H804 197 198Private Const RES_PREFIX = ".\Resources\Resources.dll" 199 200Declare Function GetLocaleInfo Lib "kernel32" Alias _ 201"GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, _ 202ByVal cchData As Long) As Long 203 204Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal fileName$) 205Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long 206Private Declare Function LoadString Lib "user32" Alias "LoadStringA" _ 207 (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, _ 208 ByVal nBufferMax As Long) As Long 209 210'WinHelp Commands 211'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 212'Public Const HELP_QUIT = &H2 ' Terminate help 213'Public Const HELP_CONTENTS = &H3& ' Display index/contents 214'Public Const HELP_CONTEXT = &H1 ' Display topic in ulTopic 215'Public Const HELP_INDEX = &H3 ' Display index 216 217Public Const CBASE_RESOURCE_DIR = ".\resources" 218Private mStrTrue As String 219Private mLocaleDir As String 220Private ghInst As Long 221 222 223Function getLocaleDir() As String 224 If mLocaleDir = "" Then 225 getLocaleLangBaseIDandSetLocaleDir 226 End If 227 getLocaleDir = mLocaleDir 228End Function 229 230Public Function GetLocaleLanguage() As String 231 Dim lReturn As Long 232 Dim lLocID As Long 233 Dim sData As String 234 Dim lDataLen As Long 235 236 lDataLen = 0 237 lReturn = GetLocaleInfo(lLocID, LOCALE_SENGLANGUAGE, sData, lDataLen) 238 sData = String(lReturn, 0) & vbNullChar 239 lDataLen = lReturn 240 lReturn = GetLocaleInfo(lLocID, LOCALE_SENGLANGUAGE, sData, lDataLen) 241 242End Function 243 244Function getLocaleLangBaseIDandSetLocaleDir() As Integer 245 On Error GoTo HandleErrors 246 Dim currentFunctionName As String 247 currentFunctionName = "getLocaleLangBaseIDandSetLocaleDir" 248 249 Dim baseID As Long 250 Dim bUseLocale As Boolean 251 Dim fso As FileSystemObject 252 Set fso = New FileSystemObject 253 254 Dim isoLangStr As String 255 Dim isoCountryStr As String 256 Dim langStr As String 257 258 Dim userLCID As Long 259 userLCID = GetUserDefaultLCID() 260 Dim sysLCID As Long 261 sysLCID = GetSystemDefaultLCID() 262 263 isoLangStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO639LANGNAME) 264 isoCountryStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO3166CTRYNAME) 265 langStr = GetUserLocaleInfo(sysLCID, LOCALE_SENGLANGUAGE) 266 267 baseID = 0 268 mLocaleDir = "" 269 270 If fso.FileExists(fso.GetAbsolutePathName("debug.ini")) Then 271 Dim overrideLangStr As String 272 overrideLangStr = ProfileGetItem("debug", "langoverride", "", fso.GetAbsolutePathName("debug.ini")) 273 If overrideLangStr <> "" Then 274 Debug.Print "Overriding language " & isoLangStr & " with " & overrideLangStr & "\n" 275 isoLangStr = overrideLangStr 276 End If 277 End If 278 279 'check for locale dirs in following order: 280 ' CBASE_RESOURCE_DIR & "\" & isoLangStr 281 ' CBASE_RESOURCE_DIR & "\" & isoLangStr & "-" & isoCountryStr 282 ' CBASE_RESOURCE_DIR & "\" & "eng" 283 'If fso.FolderExists(fso.GetAbsolutePathName(CBASE_RESOURCE_DIR & "\" & isoLangStr)) Then 284 ' mLocaleDir = CBASE_RESOURCE_DIR & "\" & isoLangStr 285 ' baseID = getBaseID(isoLangStr) 286 'ElseIf fso.FolderExists(fso.GetAbsolutePathName(CBASE_RESOURCE_DIR & "\" & isoLangStr & "-" & isoCountryStr)) Then 287 ' mLocaleDir = CBASE_RESOURCE_DIR & "\" & isoLangStr & "-" & isoCountryStr 288 ' baseID = getBaseID(isoLangStr & "-" & isoCountryStr) 289 'Else 290 mLocaleDir = CBASE_RESOURCE_DIR 291 baseID = 1000 292 'End If 293 294 getLocaleLangBaseIDandSetLocaleDir = CInt(baseID) 295 296FinalExit: 297 Set fso = Nothing 298 299 Exit Function 300 301HandleErrors: 302 Debug.Print currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 303 Resume FinalExit 304End Function 305'-------------------------------------------------------------------------- 306'this sub must be executed from the immediate window 307'it will add the entry to VBADDIN.INI if it doesn't already exist 308'so that the add-in is on available next time VB is loaded 309'-------------------------------------------------------------------------- 310Sub AddToINI() 311 Debug.Print WritePrivateProfileString("Add-Ins32", WIZARD_NAME & ".Wizard", "0", "VBADDIN.INI") 312End Sub 313 314Function GetResString(nRes As Integer) As String 315 Dim sTmp As String 316 Dim sRes As String * 1024 317 Dim sRetStr As String 318 Dim nRet As Long 319 320 Do 321 'sTmp = LoadResString(nRes) 322 nRet = LoadString(ghInst, nRes, sRes, 1024) 323 sTmp = Left$(sRes, nRet) 324 325 If Right(sTmp, 1) = "_" Then 326 sRetStr = sRetStr + VBA.Left(sTmp, Len(sTmp) - 1) 327 Else 328 sRetStr = sRetStr + sTmp 329 End If 330 nRes = nRes + 1 331 Loop Until Right(sTmp, 1) <> "_" 332 GetResString = sRetStr 333 334End Function 335 336Function GetField(sBuffer As String, sSep As String) As String 337 Dim p As Integer 338 339 p = InStr(sBuffer & sSep, sSep) 340 GetField = VBA.Left(sBuffer, p - 1) 341 sBuffer = Mid(sBuffer, p + Len(sSep)) 342 343End Function 344' Parts of the following code are from: 345' http://support.microsoft.com/default.aspx?scid=kb;en-us;232625&Product=vb6 346 347Private Function GetCharSet(sCdpg As String) As Integer 348 Select Case sCdpg 349 Case "932" ' Japanese 350 GetCharSet = 128 351 Case "936" ' Simplified Chinese 352 GetCharSet = 134 353 Case "949" ' Korean 354 GetCharSet = 129 355 Case "950" ' Traditional Chinese 356 GetCharSet = 136 357 Case "1250" ' Eastern Europe 358 GetCharSet = 238 359 Case "1251" ' Russian 360 GetCharSet = 204 361 Case "1252" ' Western European Languages 362 GetCharSet = 0 363 Case "1253" ' Greek 364 GetCharSet = 161 365 Case "1254" ' Turkish 366 GetCharSet = 162 367 Case "1255" ' Hebrew 368 GetCharSet = 177 369 Case "1256" ' Arabic 370 GetCharSet = 178 371 Case "1257" ' Baltic 372 GetCharSet = 186 373 Case Else 374 GetCharSet = 0 375 End Select 376End Function 377 378Private Function StripNullTerminator(sCP As String) 379 Dim posNull As Long 380 posNull = InStr(sCP, Chr$(0)) 381 StripNullTerminator = Left$(sCP, posNull - 1) 382End Function 383 384Private Function GetResourceDataFileName() As String 385 On Error GoTo HandleErrors 386 Dim currentFunctionName As String 387 currentFunctionName = "GetResourceDataFileName" 388 389 Dim fileName As String 390 Dim fso As FileSystemObject 391 Set fso = New FileSystemObject 392 393 GetResourceDataFileName = fso.GetAbsolutePathName(RES_PREFIX) 394 395 GoTo FinalExit 396 397 ' use the following code when we have one resource file for each language 398 Dim isoLangStr As String 399 Dim isoCountryStr As String 400 401 Dim userLCID As Long 402 userLCID = GetUserDefaultLangID() 403 Dim sysLCID As Long 404 sysLCID = GetSystemDefaultLangID() 405 406 isoLangStr = GetUserLocaleInfo(userLCID, LOCALE_SISO639LANGNAME) 407 isoCountryStr = GetUserLocaleInfo(userLCID, LOCALE_SISO3166CTRYNAME) 408 409 'check for locale data in following order: 410 ' user language 411 ' isoLangStr & "_" & isoCountryStr & ".dll" 412 ' isoLangStr & ".dll" 413 ' system language 414 ' isoLangStr & "_" & isoCountryStr & ".dll" 415 ' isoLangStr & ".dll" 416 ' "en_US" & ".dll" 417 418 fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & "-" & isoCountryStr & ".dll") 419 If fso.FileExists(fileName) Then 420 GetResourceDataFileName = fileName 421 Else 422 fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & ".dll") 423 If fso.FileExists(fileName) Then 424 GetResourceDataFileName = fileName 425 Else 426 isoLangStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO639LANGNAME) 427 isoCountryStr = GetUserLocaleInfo(sysLCID, LOCALE_SISO3166CTRYNAME) 428 429 fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & "-" & isoCountryStr & ".dll") 430 If fso.FileExists(fileName) Then 431 GetResourceDataFileName = fileName 432 Else 433 fileName = fso.GetAbsolutePathName(RES_PREFIX & isoLangStr & ".dll") 434 If fso.FileExists(fileName) Then 435 GetResourceDataFileName = fileName 436 Else 437 GetResourceDataFileName = fso.GetAbsolutePathName(RES_PREFIX & "en-US.dll") 438 End If 439 End If 440 End If 441 End If 442FinalExit: 443 Set fso = Nothing 444 Exit Function 445 446HandleErrors: 447 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 448 Resume FinalExit 449End Function 450 451Sub LoadResStrings(frm As Form) 452 Dim ctl As Control 453 Dim obj As Object 454 455 Dim LCID As Long, X As Long 456 Dim sCodePage As String 457 Dim nCharSet As Integer 458 Dim currentFunctionName As String 459 currentFunctionName = "LoadResStrings" 460 461 On Error GoTo HandleErrors 462 ghInst = LoadLibrary(GetResourceDataFileName()) 463 464 On Error Resume Next 465 466 sCodePage = String$(16, " ") 467 LCID = GetThreadLocale() 'Get Current locale 468 469 X = GetLocaleInfo(LCID, LOCALE_IDEFAULTANSICODEPAGE, _ 470 sCodePage, Len(sCodePage)) 'Get code page 471 sCodePage = StripNullTerminator(sCodePage) 472 nCharSet = GetCharSet(sCodePage) 'Convert code page to charset 473 474 'set the form's caption 475 If IsNumeric(frm.Tag) Then 476 frm.Caption = LoadResString(CInt(frm.Tag)) 477 End If 478 479 'set the controls' captions using the caption 480 'property for menu items and the Tag property 481 'for all other controls 482 For Each ctl In frm.Controls 483 Err = 0 484 If (nCharSet <> 0) Then 485 ctl.Font.Charset = nCharSet 486 End If 487 If TypeName(ctl) = "Menu" Then 488 If IsNumeric(ctl.Caption) Then 489 ctl.Caption = LoadResString(CInt(ctl.Caption)) 490 End If 491 ElseIf TypeName(ctl) = "TabStrip" Then 492 For Each obj In ctl.Tabs 493 If IsNumeric(obj.Tag) Then 494 obj.Caption = LoadResString(CInt(obj.Tag)) 495 End If 496 'check for a tooltip 497 If IsNumeric(obj.ToolTipText) Then 498 If Err = 0 Then 499 obj.ToolTipText = LoadResString(CInt(obj.ToolTipText)) 500 End If 501 End If 502 Next 503 ElseIf TypeName(ctl) = "Toolbar" Then 504 For Each obj In ctl.Buttons 505 If IsNumeric(obj.Tag) Then 506 obj.ToolTipText = LoadResString(CInt(obj.Tag)) 507 End If 508 Next 509 ElseIf TypeName(ctl) = "ListView" Then 510 For Each obj In ctl.ColumnHeaders 511 If IsNumeric(obj.Tag) Then 512 obj.Text = LoadResString(CInt(obj.Tag)) 513 End If 514 Next 515 ElseIf TypeName(ctl) = "TextBox" Then 516 If IsNumeric(ctl.Tag) Then 517 ctl.Text = LoadResString(CInt(ctl.Tag)) 518 End If 519 Else 520 If IsNumeric(ctl.Tag) Then 521 ctl.Caption = GetResString(CInt(ctl.Tag)) 522 End If 523 'check for a tooltip 524 If IsNumeric(ctl.ToolTipText) Then 525 If Err = 0 Then 526 ctl.ToolTipText = LoadResString(CInt(ctl.ToolTipText)) 527 End If 528 End If 529 End If 530 Next 531 532FinalExit: 533 Exit Sub 534 535HandleErrors: 536 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 537 Resume FinalExit 538 539End Sub 540 541'================================================== 542'Purpose: Replace the sToken string(s) in 543' res file string for correct placement 544' of localized tokens 545' 546'Inputs: sString = String to search and replace in 547' sToken = token to replace 548' sReplacement = String to replace token with 549' 550'Outputs: New string with token replaced throughout 551'================================================== 552Function ReplaceTopicTokens(sString As String, _ 553 sToken As String, _ 554 sReplacement As String) As String 555 On Error Resume Next 556 557 Dim p As Integer 558 Dim sTmp As String 559 560 sTmp = sString 561 Do 562 p = InStr(sTmp, sToken) 563 If p Then 564 sTmp = VBA.Left(sTmp, p - 1) + sReplacement + Mid(sTmp, p + Len(sToken)) 565 End If 566 Loop While p 567 568 569 ReplaceTopicTokens = sTmp 570 571End Function 572'================================================== 573'Purpose: Replace the sToken1 and sToken2 strings in 574' res file string for correct placement 575' of localized tokens 576' 577'Inputs: sString = String to search and replace in 578' sToken1 = 1st token to replace 579' sReplacement1 = 1st String to replace token with 580' sToken2 = 2nd token to replace 581' sReplacement2 = 2nd String to replace token with 582' 583'Outputs: New string with token replaced throughout 584'================================================== 585Function ReplaceTopic2Tokens(sString As String, _ 586 sToken1 As String, _ 587 sReplacement1 As String, _ 588 sToken2 As String, _ 589 sReplacement2 As String) As String 590 On Error Resume Next 591 592 ReplaceTopic2Tokens = _ 593 ReplaceTopicTokens(ReplaceTopicTokens(sString, sToken1, sReplacement1), _ 594 sToken2, sReplacement2) 595End Function 596 597 598Public Function GetResData(sResName As String, sResType As String) As String 599 Dim sTemp As String 600 Dim p As Integer 601 602 sTemp = StrConv(LoadResData(sResName, sResType), vbUnicode) 603 p = InStr(sTemp, vbNullChar) 604 If p Then sTemp = VBA.Left$(sTemp, p - 1) 605 GetResData = sTemp 606End Function 607 608Function AddToAddInCommandBar(VBInst As Object, sCaption As String, oBitmap As Object) As Object 'Office.CommandBarControl 609 On Error GoTo AddToAddInCommandBarErr 610 611 Dim c As Integer 612 Dim cbMenuCommandBar As Object 'Office.CommandBarControl 'command bar object 613 Dim cbMenu As Object 614 615 'see if we can find the Add-Ins menu 616 Set cbMenu = VBInst.CommandBars("Add-Ins") 617 If cbMenu Is Nothing Then 618 'not available so we fail 619 Exit Function 620 End If 621 622 'add it to the command bar 623 Set cbMenuCommandBar = cbMenu.Controls.add(1) 624 c = cbMenu.Controls.count - 1 625 If cbMenu.Controls(c).BeginGroup And _ 626 Not cbMenu.Controls(c - 1).BeginGroup Then 627 'this s the first addin being added so it needs a separator 628 cbMenuCommandBar.BeginGroup = True 629 End If 630 'set the caption 631 cbMenuCommandBar.Caption = sCaption 632 'undone:set the onaction (required at this point) 633 cbMenuCommandBar.OnAction = "hello" 634 'copy the icon to the clipboard 635 Clipboard.SetData oBitmap 636 'set the icon for the button 637 cbMenuCommandBar.PasteFace 638 639 Set AddToAddInCommandBar = cbMenuCommandBar 640 641 Exit Function 642AddToAddInCommandBarErr: 643 644End Function 645 646