'VBLM_RTA_WR.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: No
'Write Language Selection to Registry: Yes
'Read Language Selection from Registry: Has commented-out code to do this
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
'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
'VBLM will uncomment the following for VB3- projects
'Const vbHourglass = 11 'uncomment for VB3
'Const vbCritical = 16 'uncomment for VB3
'Const vbAbortRetryIgnore = 2 'uncomment for VB3
'Const vbExclamation = 48 'uncomment for VB3
'Const vbABORT = 3 'uncomment for VB3
'Const vbRETRY = 4 'uncomment for VB3
'Const vbIGNORE = 5 'uncomment for VB3
'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
'VBLM will replace this with appropriate Win16 declaration in VB3- projects
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
'
'=================================================================
'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 = "~~"
' 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
MsgBox "Fatal Error: Language database file " & sFileName & " not found.", vbCritical
End
End If
'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
ReDim sLanguages(lNumLanguages), lOffsets(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
'uncomment this is you want VBLM to use the last language selected, without
'prompting the user
'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
'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 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
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
'load the rts support form, and fill in the list of language choices
Load frmVBLM_RTS
For li = 1 To lNumLanguages
frmVBLM_RTS.lstLanguages.AddItem sLanguages(li)
Next
'center it on the screen, set an arrow cursor, show it modally
frmVBLM_RTS.Move (Screen.Width - frmVBLM_RTS.Width) \ 2, (Screen.Height - frmVBLM_RTS.Height) \ 2
Screen.MousePointer = 1
frmVBLM_RTS.Show 1
'get the selected language and unload
mlSelectedLanguage = frmVBLM_RTS.lstLanguages.ListIndex + 1
Unload frmVBLM_RTS
End If
'save the language choice in the registry
li = ReadWriteLanguageToRegistry(KEY_WRITE, sLanguages(mlSelectedLanguage))
'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
'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 EndOnMissingData sFileName
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 is string indices are contiguous
Else
If lStringIndexBase = 0 And lStringIndexStep = 1 Then EndOnMissingData sFileName
End If
Next
'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
End
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 EndOnMissingData sFileName
End Function
Sub EndOnMissingData(sFileName As String)
MsgBox "Fatal Error: Language database file " _
& sFileName _
& " is missing critical information.", vbCritical
End
End Sub
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