'VBLM_RTB_WR.BAS: 'VB Language Manager Runtime Language Switching Support Module
'Copyright 1994-2002 by WhippleWare. All Rights Reserved
'Language Database Format Supported: BINARY
'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
'==============================================================
'DECLARATIONS
'==============================================================
Option Explicit
DefLng A-Z
'uncomment the following if running VB3 or earlier
'const vbHourglass = 11
'Const vbCritical = 16
'Const vbAbortRetryIgnore = 2
'Const vbExclamation = 48
'Const vbABORT = 3
'Const vbRETRY = 4
'Const vbIGNORE = 5
'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
'these module level elements are shared by the routine that fetches
'strings and the routine that fetches dimsets
'mLanguageSelected is used to get the language choice
Dim mlSelectedLanguage As Long
'mlDatabaseHandle
Dim mlDatabaseHandle As Long
Sub OpenDatabaseFile()
'RTS_FILE is the name of the database file created by VBLM
'VBLM 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 -- don't remove them
Const RTS_FILE = "LANGUAGE.DAT" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim sFileName As String
'grab a handle
mlDatabaseHandle = FreeFile
'if filename includes a directory spec, assume it's a full path
'otherwise look in application directory
If InStr(RTS_FILE, ":\") + InStr(RTS_FILE, "\\") = 0 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
'open for binary
Open sFileName For Binary As mlDatabaseHandle
End Sub
'=================================================================
'The VBLM_RTString function is the core of runtime switching (RSV)
'
'All translated sStrings 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 sLanguages) by
'passing -1 as the Index argument value
'=================================================================
'=================================================================
'
Function VBLM_RTString(Index As Long) As String
'=================================================================
' LOCAL DECLARATIONS
'=================================================================
'=================================================================
'cOPTIMIZATION METHOD (Binary version only)
'VBLM_RTString allows you to optimize its performance for either memory or speed.
'When optimized for speed (the default), it only goes to disk the first time
'it is called, and loads the entire language table into an array in memory.
'Subsequent calls are very fast, and since the sStrings() array consists of
'user-defined types, it does not intrude on local string space.
'If your application has a very large language table, however, this method
'might cause memory problems. If so, redefine the cOPTIMIZATION constant below
'from cOPTIMIZE_FOR_SPEED to cOPTIMIZE_FOR_MEMORY.
'When optimized for memory, VBLM_RTString initializes by loading the lPtrs() array
'with each string's offset in the file, which are then used on subsequent calls
'to fetch sStrings "from disk." li use the quotes here because if the host
'system is using a disk cache, which it probably is, fewer than 1 in 10 calls
'are apt to cause an actual read; the other 9 will be in the cache
Const cOPTIMIZE_FOR_MEMORY = 0
Const cOPTIMIZE_FOR_SPEED = 1
Const cOPTIMIZATION = cOPTIMIZE_FOR_SPEED 'set this to your preference
'=================================================================
'REINIT_LDB is the Index value that forces reinitializtion
Const REINIT_LDB = -1
'CRLF_ALIAS is the alias for embedded carriage returns
Const CRLF_ALIAS = "~~"
'=================================================================
' STATIC VARIABLES
'lPtrs() hold string location data when optimized for memory
Static lPtrs() As Long
'sStrings() hold actual Strings when optimized for speed
Static sStrings() As String
'bInit is the initialization flag
Static bInit As Boolean
'lIndexBase and lIndexStep are the values used to create the
'current indexing scheme, and are read from the LDB
Static lIndexBase as Long, lIndexStep as Long
'=================================================================
' TRANSIENT VARIABLES USED ONLY ON FIRST CALL (INITIALIZATION)
'
'lNumLanguages = number of sLanguages in the database
Dim lNumLanguages As Long
'lNumStrings = number of entries in each language table
Dim lNumStrings As Long
'lIndex = local index computed from the one passed in using index base and step
'lIndex = (Index-Base)/Step
Dim lIndex as Long
'li = for-next counter variable
'lcp = cursor position for string manipulation
Dim li As Long, lcp As Long
'lPreviousMousePointer = MousePointer Cache Variable
Dim lPreviousMousePointer As Long
'lOffsets() = location in file of beginning of each language table
Dim lOffsets() As Long
'sRegLanguage = Name of Language stored in registry
Dim sRegLanguage As String
'sLanguages() = Names of sLanguages in the the database
Dim sLanguages() As String
'=================================================================
' TRANSIENT VARIABLE USED ON ALL CALLS WHEN OPTIMIZED FOR MEMORY
'sTmp = tmp string var, lStrLen = length of each string
Dim sTmp As String
Dim lStrLen As Long
'=================================================================
' EXECUTABLE CODE BEGINS HERE
'=================================================================
'INITIALIZATION CODE: EXECUTES ONLY ON FIRST CALL
'=================================================================
If bInit = 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
'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
'open the database file (in a sub in case we need to call it again)
'Note: if we're here because user forced a reinit (ie Index=-1, mlDatabaseHandle <>0)
'AND if cOPTIMIZATION method = memory, then file is already open
If mlDatabaseHandle = False Then OpenDatabaseFile
'get the number of sLanguages, location of dimset (if any)
Get #mlDatabaseHandle, 1, lNumLanguages
'file has reserved dimset entry -- get and ignore
Get #mlDatabaseHandle, , lStrLen
'get the base and step used to create the index numbers that will be passed in
Get #mlDatabaseHandle, , lIndexBase
Get #mlDatabaseHandle, , lIndexStep
'redim name and offset arrays
ReDim sLanguages(lNumLanguages), lOffsets(lNumLanguages)
'get the name and offset of each language table
'while iterating, check for a command line match, flag = "/L="
For li = 1 To lNumLanguages
Get #mlDatabaseHandle, , lStrLen
sLanguages(li) = Space$(lStrLen)
Get #mlDatabaseHandle, , sLanguages(li)
Get #mlDatabaseHandle, , lOffsets(li)
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, select it
If lNumLanguages = 1 Then mlSelectedLanguage = 1
'if language not yet selected, query the user
If mlSelectedLanguage = False Or Index = REINIT_LDB 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 sStrings in a language table
Get #mlDatabaseHandle, , lNumStrings
'and, depending on cOPTIMIZATION method, make room either for sStrings or pointers
If cOPTIMIZATION = cOPTIMIZE_FOR_SPEED Then
ReDim sStrings(lNumStrings)
ElseIf cOPTIMIZATION = cOPTIMIZE_FOR_MEMORY Then
ReDim lPtrs(lNumStrings)
End If
'seek to the beginning of the selected table
Seek mlDatabaseHandle, lOffsets(mlSelectedLanguage)
'and for each string
'either retrieve its value into sStrings() or its location into lPtrs()
For li = 1 To lNumStrings
If cOPTIMIZATION = cOPTIMIZE_FOR_MEMORY Then lPtrs(li) = Seek(mlDatabaseHandle)
Get #mlDatabaseHandle, , lStrLen
sTmp = Space$(lStrLen)
Get #mlDatabaseHandle, , sTmp
If cOPTIMIZATION = cOPTIMIZE_FOR_SPEED Then
sStrings(li) = sTmp
'insert crlfs
Do While InStr(sStrings(li), CRLF_ALIAS)
lcp = InStr(sStrings(li), CRLF_ALIAS)
If lcp Then sStrings(li) = Left$(sStrings(li), lcp - 1) & Chr$(13) & Chr$(10) & Mid$(sStrings(li), lcp + Len(CRLF_ALIAS))
Loop
End If
Next
'if we've read and saved the sStrings, close the file
'otherwise we need to keep it open
If cOPTIMIZATION = cOPTIMIZE_FOR_SPEED Then
Close mlDatabaseHandle
mlDatabaseHandle = 0
End If
'restore the original cursor state
Screen.MousePointer = lPreviousMousePointer
'set the initialization flag
bInit = True
'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 two likely errors, so deal with them as needed
On Error Resume Next
'compute the local index
lIndex = (Index - lIndexBase) / lIndexStep
If cOPTIMIZATION = cOPTIMIZE_FOR_SPEED Then
'return string from array
VBLM_RTString = sStrings(lIndex)
'possible error: index out of range; so indicate
If Err = 9 Then VBLM_RTString = "Invalid Index"
ElseIf cOPTIMIZATION = cOPTIMIZE_FOR_MEMORY Then
'read string from disk
Get #mlDatabaseHandle, lPtrs(lIndex), lStrLen
sTmp = Space$(lStrLen)
Get #mlDatabaseHandle, , sTmp
'possible error: bad file handle, because somebody's "Close" elsewhere closed our file
If Err = 9 Then
sTmp = "Invalid Index"
ElseIf Err = 52 Then
Err = 0
OpenDatabaseFile
Get #mlDatabaseHandle, lPtrs(lIndex), lStrLen
sTmp = Space$(lStrLen)
Get #mlDatabaseHandle, , sTmp
If Err Then sTmp = "Unable to retrieve string"
End If
'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
VBLM_RTString = sTmp
End If
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 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