VBLM_RTR_WR.bas

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

'Copyright 1994-2002 by WhippleWare. All Rights Reserved

 

'Language Database Format Supported: Resource File

 

'Support for Runtime Switching of Interface Dimensions: No

 

'Write Language Selection to Registry: Yes

 

'Read Language Selection from Registry: Code present but commented out

 

Option Explicit

DefLng A-Z

 

'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

 

 

'Language Selected by user or command line

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

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

 

'REINIT_LDB is the Index value that forces reinitializtion

Const REINIT_LDB = -1

 

' STATIC VARIABLES

'iInitialized is the initialization flag that causes this

'function to prompt the user for a language choice, but only

'the first time it is called, or when passed REINIT_LDB

 

Static iInitialized As Integer 

 

'lCurrentOffset is the offset used to return strings from the

'selected language

Static lCurrentOffset As Long 

 

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

' TRANSIENT VARIABLES USED ONLY DURING INITIALIZATION

 

'lNumLanguages = number of languages available

Dim lNumLanguages As Long 

 

'li = iteration index

Dim li As Long 

 

'lEachLanguageOffset is the offset between each language in

'the resource file

Dim lEachLanguageOffset As Long 

 

'sRegLanguage = Name of Language stored in registry

Dim sRegLanguage As String 

 

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

Dim sLanguages() As String 

 

'sTmp = tmp string variable

Dim sTmp As String 

 

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

' EXECUTABLE CODE BEGINS HERE

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

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

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

 

'Handle is used as the initialization flag

If iInitialized = 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 

 

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

'NOTE: VBLM appends the GetLanguages() routine to this module during

'a build, as it is composed of build-specific information

lNumLanguages = GetLanguages(sLanguages(), lEachLanguageOffset) 

 

'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

 

'if only one language in database, select it

If lNumLanguages = 1 Then mlSelectedLanguage = 1 

 

If mlSelectedLanguage = False Then 

'check command line and registry entry for language choice

For li = 1 To lNumLanguages 

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 

End If 

 

'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 

 

lCurrentOffset = (mlSelectedLanguage - 1) * lEachLanguageOffset 

 

'save the language choice in the registry

li = ReadWriteLanguageToRegistry(KEY_WRITE, sLanguages(mlSelectedLanguage)) 

 

'mark as Initialized

iInitialized = 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 one likely error, so deal with it as needed

On Error Resume Next 

 

'return string from array

VBLM_RTString = LoadResString(lCurrentOffset + Index) 

 

'error: invalid index

If Err 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 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.

'

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