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