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 localization
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