'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