VBLM_RTA_D_RR.bas

'VBLM_RTA_D_RR.BAS: VB Language Manager Runtime Language Switching Support Module

'Copyright 1994-2002 by WhippleWare. All Rights Reserved

 

 

'Language Database Format Supported: ANSI text

 

'Support for Runtime Switching of Interface Dimensions: Yes

 

'Write Language Selection to Registry: No

 

'Read Language Selection from Registry: Yes

 

'This module is for DLL's and other secondary apps, as it does not allow a language choice.

'Instead, it reads it from the registry, assuming it has already been written there by the

'main app.

 

'It also examines the command line for a choice (/L=Language)

'If neither is found, it defaults to the first language

 

Option Explicit

DefLng A-Z

 

'tagVBLM_VS is the record type for the language database

'although ANSI text format databases do NOT use it for disk storage

'VBLM still uses a static array of type tagVBLM_VS for in-memory storage

'this keeps the strings out of the app's local string space

Type tagVBLM_VS

String As String 

End Type

 

'type to hold control location+size, for runtime switching of interface dimensions

Type tagControlDims

CtrlX As Long 

Left As Long 

Top As Long 

Width As Long 

Height As Long 

Ptr As Long 

End Type

 

'tagProfileEntry is a type used to pass data needed to read profile string type entries

'from the language database file

Type tagProfileEntry

KeyName As String 

KeyValue As String 

nKeyValue As Long 

Critical As Boolean 

End Type

 

'Registry API constants and functions

Const KEY_WRITE = &H20006

Const KEY_READ = &H20019

 

Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

 

'aliased API function

Declare Function GPPS Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal Section$, ByVal Key$, ByVal sDflt$, ByVal ReturnedString$, ByVal MaxSize&, ByVal File$) As Long

 

'Language Selected by user or command line - module level to share with DimSet function

Dim mlSelectedLanguage As Long

 

'mlDimSetEntries tells us if database file contains dimsets (for runtime

'interface resizing), and if so, how many entries in each one

Dim mlDimSetEntries As Long

 

'mDimSet() contains the interface dimension strings, loaded at language selection time

Dim msDimSetStrings() As String

 

'mlDimSetX() is the (Project, File) index into the dimset

Dim mlDimSetX() As Long

 

'since you can't End in a DLL, LDB critical errors cause an error message return instead

Dim mbCriticalError As Boolean

 

'

'=================================================================

'The VBLM_RTString function is the core of runtime switching (RSV)

'

'All translated strings and properties have been replaced with

'calls to VBLM_RTString

'

'The function is passed an index and returns a string

'The first call initializes the database

'You can also force reinitialization (ie change languages) by passing

'a value of -1 as the Index argument

'=================================================================

'=================================================================

'

Function VBLM_RTString(Index As Long) As String

 

'=================================================================

' LOCAL DECLARATIONS

'=================================================================

 

'RTS_FILE is the name of the database file created by VBLM

'VBLM_RTString expects to find it in the application directory

'the default is "LANGUAGE.DAT", but this is a user-definable RSV Build Option

'the embedded 's are placeholders for VBLM to insert longer names

Const RTS_FILE = "LANGUAGE.DAT" '''''''''''''''''''''''''''''''''''''''

 

'REINIT_LDB is the Index value that forces reinitializtion

Const REINIT_LDB = -1

 

'CRLF_ALIAS is the alias for carriage returns embedded in strings

Const CRLF_ALIAS = "~~"

 

Const cCriticalError = "LDB Error - String not available"

 

' STATIC VARIABLES

'Handle is the database file handle, also used as the initialization flag

Static lHandle As Long 

 

'Strings() will hold the strings we're going to fetch and use

Static Strings() As tagVBLM_VS 

 

'=================================================================

' TRANSIENT VARIABLES USED ONLY DURING INITIALIZATION

 

'PE = type for reading keyed data from the language database file

Dim PE As tagProfileEntry 

 

'lNumLanguages = number of languages in the database

Dim lNumLanguages As Long 

 

'lNumStrings = number of entries in each language table

Dim lNumStrings As Long 

 

'lStringIndexBase and lStringIndexStep are used to describe non-contiguous

'indexing schemes

Dim lStringIndexBase As Long, lStringIndexStep As Long 

 

'li = for-next counter variable

Dim li As Long 

 

'lcp = cursor position while parsing a string

Dim lcp As Long 

 

'sIndex = value of string index contained in string entry

Dim sIndex As Long 

 

'lPreviousMousePointer = MousePointer Cache Variable

Dim lPreviousMousePointer As Long 

 

'sFileName = Full path and FileName of language database file

Dim sFileName As String 

 

'lOffsets() = location in file of beginning of each language table

Dim lOffsets() As Long 

 

'lDimSetOffsets() = location in file of beginning of each DimSet

Dim lDimSetOffsets() As Long 

 

'sLanguages() = Names of Languages in the the database

Dim sLanguages() As String 

 

'sRegLanguage = Name of Language stored in registry

Dim sRegLanguage As String 

 

'sTmp = tmp string variable, used to read from disk

Dim sTmp As String 

 

'=================================================================

' EXECUTABLE CODE BEGINS HERE

'=================================================================

'INITIALIZATION CODE: EXECUTES ON FIRST CALL OR WHEN INDEX = REINIT_LDB

'=================================================================

 

'lHandle is used as the initialization flag

If lHandle = False Or Index = REINIT_LDB Then 

 

'Default Error handling

On Error GoTo RTS_Error 

 

'reset language choice (needed for switch-on-the-fly)

mlSelectedLanguage = 0 

 

'cache the current cursor

lPreviousMousePointer = Screen.MousePointer 

 

'grab a file handle

lHandle = FreeFile 

 

'look for file in application directory unless user has specified a directory

If InStr(RTS_FILE, "\") = False Then 

sFileName = App.Path 

If Right$(sFileName, 1) <> "\" Then sFileName = sFileName & "\" 

sFileName = sFileName & RTS_FILE 

Else 

sFileName = RTS_FILE 

End If 

 

'if file not found, terminate; you can gussy this up as desired

If Dir$(sFileName) = "" Then 

VBLM_RTString = "Language database file " & sFileName & " not found." 

Exit Function 

End If 

 

'find out if database contains DimSets as well as strings

PE.KeyName = "DimSetEntries" 

PE.Critical = False 

If VBLM_GetProfileString(PE, sFileName) Then mlDimSetEntries = PE.nKeyValue 

 

 

'get the number of languages and redim name and offset arrays

PE.KeyName = "NumLanguages" 

 

'note: setting PE.Critical = True will cause VBLM_GetProfileString to end the app if

'data is missing -- set now, stays set until unset below

PE.Critical = True 

 

If VBLM_GetProfileString(PE, sFileName) Then lNumLanguages = PE.nKeyValue 

If mbCriticalError Then 

VBLM_RTString = cCriticalError 

Exit Function 

End If 

 

ReDim sLanguages(lNumLanguages), lOffsets(lNumLanguages) 

If mlDimSetEntries Then ReDim lDimSetOffsets(lNumLanguages) 

 

'get the name and offset of each language table

'while iterating, check for a command line match, flag = "/L="

'or for a match with the language stored in the registry

 

'check registry for a recorded selection

If ReadWriteLanguageToRegistry(KEY_READ, sTmp) Then sRegLanguage = sTmp 

 

For li = 1 To lNumLanguages 

 

'construct the language name key

PE.KeyName = "Language" & Format$(li) 

 

'get the value and assign it if found, else bail

If VBLM_GetProfileString(PE, sFileName) Then sLanguages(li) = PE.KeyValue 

If mbCriticalError Then 

VBLM_RTString = cCriticalError 

Exit Function 

End If 

 

'now ditto for the offset values (file location where languages start)

'and assign it if found, else bail

PE.KeyName = "Language" & Format$(li) & "Start" 

If VBLM_GetProfileString(PE, sFileName) Then lOffsets(li) = PE.nKeyValue 

If mbCriticalError Then 

VBLM_RTString = cCriticalError 

Exit Function 

End If 

 

If InStr(1, Command$, "/L=" & sLanguages(li), 1) Then mlSelectedLanguage = li 

 

'registry will not override, and will be overridden by, command line selection 

If mlSelectedLanguage = False And Len(sRegLanguage) > 0 Then 

If StrComp(sLanguages(li), sRegLanguage, 1) = 0 Then mlSelectedLanguage = li 

End If 

 

'if present, find offsets to dimsets

If mlDimSetEntries Then 

PE.KeyName = "Language" & Format$(li) & "DimSet" 

If VBLM_GetProfileString(PE, sFileName) Then lDimSetOffsets(li) = PE.nKeyValue 

If mbCriticalError Then 

VBLM_RTString = cCriticalError 

Exit Function 

End If 

End If 

 

Next 

 

'if only one language in database, select it

If lNumLanguages = 1 Then mlSelectedLanguage = 1 

 

'else if language not specified on command line, query the user

If mlSelectedLanguage = False Then mlSelectedLanguage = 1 

 

'look busy

Screen.MousePointer = vbHourglass 

 

'get the number of strings in a language table

PE.KeyName = "NumStrings" 

If VBLM_GetProfileString(PE, sFileName) Then lNumStrings = PE.nKeyValue 

If mbCriticalError Then 

VBLM_RTString = cCriticalError 

Exit Function 

End If 

 

'read the numbering scheme parameters: base and step

PE.KeyName = "StringIndexBase" 

'data is no longer critical

PE.Critical = False 

 

If VBLM_GetProfileString(PE, sFileName) Then 

lStringIndexBase = PE.nKeyValue 

Else 

lStringIndexBase = 0 

End If 

 

PE.KeyName = "StringIndexStep" 

If VBLM_GetProfileString(PE, sFileName) Then 

lStringIndexStep = PE.nKeyValue 

Else 

lStringIndexStep = 1 

End If 

 

'make room for the strings

ReDim Strings(lStringIndexBase + lNumStrings * lStringIndexStep) 

 

'open the file and seek to the beginning of the selected table

'Note: the following method for loading the strings is 2-3 times faster then

'Windows' GetPrivateProfileString () function

 

Open sFileName For Input As lHandle 

Seek lHandle, lOffsets(mlSelectedLanguage) 

 

'Offset will be correct unless user has edited & screwed up the file, so test it

'the line should be "[Name_of_Selected_Language]"

Line Input #lHandle, sTmp 

sTmp = Trim$(sTmp) 

 

'if it isn't (strcomp returns a value when NOT a match), then

'read file from beginning until line is found

If StrComp(sTmp, "[" & sLanguages(mlSelectedLanguage) & "]") Then 

Seek lHandle, 1 

Do Until EOF(lHandle) 

Line Input #lHandle, sTmp 

sTmp = Trim$(sTmp) 

If StrComp(sTmp, "[" & sLanguages(mlSelectedLanguage) & "]") = False Then Exit Do 

Loop 

If EOF(lHandle) Then 

VBLM_RTString = cCriticalError 

Exit Function 

End If 

End If 

 

'now retrieve each string

'vblm will have created a file with "s[value]="string""

'we will test the value and insert string in appropriate place

For li = 1 To lNumStrings 

Line Input #lHandle, sTmp 

lcp = InStr(sTmp, "=") 

If lcp Then 

 

'compute sIndex

sIndex = Val(Mid$(sTmp, 2, lcp - 1)) 

 

'ignore all to left of equal sign

sTmp = Mid$(sTmp, lcp + 1) 

 

'trim quotes

If Asc(sTmp) = 34 Then sTmp = Mid$(sTmp, 2) 

If Asc(Right$(sTmp, 1)) = 34 Then sTmp = Left$(sTmp, Len(sTmp) - 1) 

 

'insert crlfs

Do While InStr(sTmp, CRLF_ALIAS) 

lcp = InStr(sTmp, CRLF_ALIAS) 

If lcp Then sTmp = Left$(sTmp, lcp - 1) & Chr$(13) & Chr$(10) & Mid$(sTmp, lcp + Len(CRLF_ALIAS)) 

Loop 

 

Strings(sIndex).String = sTmp 

 

ElseIf StrComp(Left$(sTmp, 1), "[") = 0 Then 'hit the next section 

Exit For 

'only report error on missing string if string indices are contiguous

Else 

If lStringIndexBase = 0 And lStringIndexStep = 1 Then 

VBLM_RTString = cCriticalError 

Exit Function 

End If 

End If 

Next 

 

If mlDimSetEntries Then 

ReDim msDimSetStrings(mlDimSetEntries) 

Seek lHandle, lDimSetOffsets(mlSelectedLanguage) 

Line Input #lHandle, sTmp 'dimset name 

For li = 1 To mlDimSetEntries 

Line Input #lHandle, msDimSetStrings(li) 

Next 

End If 

 

'close the file and restore the original cursor state

Close lHandle 

Screen.MousePointer = lPreviousMousePointer 

 

'and bail if just here to reinit

If Index = REINIT_LDB Then Exit Function 

 

End If 

 

'=================================================================

' END OF INITIALIZATION CODE

' FOLLOWING CODE EXECUTES ON ALL CALLS TO RETURN THE STRING

'=================================================================

 

'only one likely error, so deal with it as needed

On Error Resume Next 

 

'return string from array

VBLM_RTString = Strings(Index).String 

 

'possible error: index out of range; so indicate

If Err = 9 Then VBLM_RTString = "Invalid Index" 

 

Exit Function 

 

'=================================================================

' END OF MAIN FUNCTION CODE

'=================================================================

 

'=================================================================

' default error handler

'=================================================================

RTS_Error:

Select Case MsgBox(Error$ & "(Code" & Str$(Err) & ")", vbExclamation + vbAbortRetryIgnore, "VBLM_RTString()") 

Case vbAbort 

VBLM_RTString = cCriticalError 

Exit Function 

Case vbRetry 

Resume 

Case vbIgnore 

Resume Next 

Case Else 

End Select 

 

End Function

 

Function VBLM_GetProfileString(PE As tagProfileEntry, sFileName As String) As Boolean

 

'fetch a profile string from a file -- return true if found

 

Const cDefaultValue = "?" 

Const PS_SIZE = 64 

Dim lcp As Long 

 

PE.KeyValue = Space$(PS_SIZE) 

lcp = GPPS("VBLM", PE.KeyName, cDefaultValue, PE.KeyValue, PS_SIZE, sFileName) 

If lcp Then 

PE.KeyValue = Left$(PE.KeyValue, lcp) 

PE.nKeyValue = Val(PE.KeyValue) 

If StrComp(PE.KeyValue, cDefaultValue) Then 'if DOESN'T match 

VBLM_GetProfileString = True 

Exit Function 

End If 

End If 

 

If PE.Critical Then mbCriticalError = True 

 

End Function

Function VBLM_GetDimensions(PrjX As Long, FileX As Long, ControlDims() As tagControlDims, iScaleMode As Integer) As Long

 

Static bInit As Boolean 

Dim li As Long, j As Long, lcp As Long 

Dim lMaxPrj As Long, lMaxFile As Long, lTmp As Long 

Dim sTmp As String 

 

If bInit = False Then 

lMaxPrj = Val(msDimSetStrings(mlDimSetEntries)) 

For li = 1 To mlDimSetEntries 

lTmp = Val(Mid$(msDimSetStrings(li), InStr(msDimSetStrings(li), "_") + 1)) 

If lTmp > lMaxFile Then lMaxFile = lTmp 

Next 

ReDim mlDimSetX(lMaxPrj, lMaxFile) 

For li = 1 To mlDimSetEntries 

mlDimSetX(Val(msDimSetStrings(li)), Val(Mid$(msDimSetStrings(li), InStr(msDimSetStrings(li), "_") + 1))) = li 

Next 

bInit = True 

End If 

 

VBLM_GetDimensions = StringToControlDims(msDimSetStrings(mlDimSetX(PrjX, FileX)), ControlDims(), iScaleMode) 

 

End Function

Function StringToControlDims(DimSetString As String, ControlDims() As tagControlDims, iScaleMode As Integer) As Long

 

Const SM_Pixels = 3 

 

'DimSetString holds list of values, as stored in database 

Dim li As Long, j As Long, lcp As Long 

Dim sTmp As String 

Dim NumControlDims As Long, lTmp As Long 

 

lcp = InStr(DimSetString, "=") 

sTmp = Mid$(DimSetString, lcp + 1) 

 

NumControlDims = Val(sTmp) 

ReDim ControlDims(NumControlDims) 

 

lcp = InStr(sTmp, ",") 

sTmp = Mid$(sTmp, lcp + 1) 

 

For li = 1 To NumControlDims 

For j = 1 To 6 

 

lTmp = Val(sTmp) 

 

Select Case j 

Case 1: ControlDims(li).CtrlX = lTmp 

Case 2: ControlDims(li).Left = lTmp 

Case 3: ControlDims(li).Top = lTmp 

Case 4: ControlDims(li).Width = lTmp 

Case 5: ControlDims(li).Height = lTmp 

Case 6: ControlDims(li).Ptr = lTmp 

Case Else 

End Select 

 

lcp = InStr(sTmp, ",") 

sTmp = Mid$(sTmp, lcp + 1) 

Next 

'raw data is in twips -- adjust for pixels 

If li > 1 And iScaleMode = SM_Pixels Then 

ControlDims(li).Left = ControlDims(li).Left / Screen.TwipsPerPixelX 

ControlDims(li).Top = ControlDims(li).Top / Screen.TwipsPerPixelY 

ControlDims(li).Width = ControlDims(li).Width / Screen.TwipsPerPixelX 

ControlDims(li).Height = ControlDims(li).Height / Screen.TwipsPerPixelY 

End If 

Next 

 

StringToControlDims = NumControlDims 

 

End Function

 

 

Function ReadWriteLanguageToRegistry(Action As Long, Language As String) As Long

 

Const HKEY_LOCAL_MACHINE = &H80000002 

Const REG_SZ = 1 

Const KeyName = "Software\WhippleWare\VBLM" 

Const KeyWord = "LastLanguage" 

Const NO_ERROR = 0 

 

Dim KeyValue As String 

Dim hKeyResult As Long, kvl As Long 

Dim KeyOpenStatus As Long 

 

KeyOpenStatus = RegOpenKeyEx(HKEY_LOCAL_MACHINE, KeyName, 0, Action, hKeyResult) 

 

If KeyOpenStatus <> NO_ERROR And Action = KEY_WRITE Then 

KeyOpenStatus = RegCreateKey(HKEY_LOCAL_MACHINE, KeyName, hKeyResult) 

End If 

 

If KeyOpenStatus = NO_ERROR Then 

If Action = KEY_READ Then 

KeyValue = Space$(64&) 

kvl = 64& 

KeyOpenStatus = RegQueryValueEx(hKeyResult, KeyWord, 0, REG_SZ, ByVal KeyValue, kvl) 

If KeyOpenStatus = NO_ERROR And kvl > 0 Then 

Language = Left$(KeyValue, kvl) 

'some OS's return the null, others don't 

If Asc(Right$(Language, 1)) = 0 Then Language = Left$(Language, Len(Language) - 1) 

ReadWriteLanguageToRegistry = True 

End If 

ElseIf Action = KEY_WRITE Then 

KeyValue = Language 

kvl = Len(Language) 

KeyOpenStatus = RegSetValueEx(hKeyResult, KeyWord, 0, REG_SZ, ByVal KeyValue, kvl) 

ReadWriteLanguageToRegistry = (KeyOpenStatus = NO_ERROR) 

End If 

 

kvl = RegCloseKey(hKeyResult) 

 

End If 

 

End Function

 

Sub VBLM_UserPrefixCode(frm As Form)

'This stub is the default "User Prefix" code that will be called

'in the VBLM_SetProperties event when the "Include User Code"

'RSV option is checked. Code inserted here will be executed whenever

'RSV forms load or are refreshed by VBLM_SwitchOnTheFly.

'

'This allows you to customize the form initialization process.

'

'Note that the prefix code is called FIRST in VBLM_SetProperties.

'If you want your code to execute LAST, put it in VBLM_UserSuffixCode.

'

'Note also that you can change the names of this procedure, call multiple

'procedures, etc etc, by modifying the UserPrefix and/or UserSuffix. You

'are given the opportunity to do so whenever you turn on "Include User Code"

'

'A big HATS OFF to Ron Gordon at GGT for suggesting this feature!

'

End Sub

 

Sub VBLM_UserSuffixCode(frm As Form)

'This stub is the default "User Suffix" code that will be called

'in the VBLM_SetProperties event when the "Include User Code"

'RSV option is checked. Code inserted here will be executed whenever

'RSV forms load or are refreshed by VBLM_SwitchOnTheFly.

'

'This allows you to customize the form initialization process.

'

'Note that the suffix code is called LAST in VBLM_SetProperties.

'If you want your code to execute FIRST, put it in VBLM_UserPrefixCode.

'

'Note also that you can change the names of this procedure, call multiple

'procedures, etc etc, by modifying the UserPrefix and/or UserSuffix. You

'are given the opportunity to do so whenever you turn on "Include User Code"

 

'A big HATS OFF to Ron Gordon at GGT for suggesting this feature!

'

End Sub