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