'VBLM_RTR_D.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: Yes
'Write Language Selection to Registry: No
'Read Language Selection from Registry: No
Option Explicit
DefLng A-Z
'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
'module level vars, shared between language and dimset routines (if present)
'Language Selected by user or command line
Dim mlSelectedLanguage As Long
'these values describe the size and structure of the dimsets stored in
'in the resource file. VBLM writes their values into this file when
'it performs the build. They are used in VBLM_GetDimensions() to locate
'and load dimsets given a language choice and a file index
Dim mlDimResFirstID As Long
Dim mlDimSetBlockSize As Long
Dim mlProjectDimSetBlockSize 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
'i = iteration index
Dim i As Long
'lEachLanguageOffset is the offset between each language in
'the resource file
Dim lEachLanguageOffset As Long
'sLanguages() = Names of Languages in the the database
Dim sLanguages() 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)
'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 i = 1 To lNumLanguages
frmVBLM_RTS.lstLanguages.AddItem sLanguages(i)
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
'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 VBLM_GetDimensions(PrjX As Long, FileX As Long, ControlDims() As tagControlDims, iScaleMode As Integer) As Long
Const RT_RCDATA = 10
Dim ControlDimBytes() As Byte
Dim ResourceOffset As Long
ResourceOffset = mlDimResFirstID _
+ (mlSelectedLanguage - 1) * mlDimSetBlockSize _
+ (PrjX - 1) * mlProjectDimSetBlockSize _
+ FileX
ControlDimBytes = LoadResData(ResourceOffset, RT_RCDATA)
VBLM_GetDimensions = BytesToControlDims(ControlDimBytes(), ControlDims(), iScaleMode)
End Function
Function BytesToControlDims(Bytes() As Byte, ControlDims() As tagControlDims, iScaleMode As Integer) As Long
Const SM_Pixels = 3
'bytes() holds long values, stored lsb first
Dim i As Long, j As Long, k As Long, bx As Long
Dim tmpCtrlDims As tagControlDims, CtrlDimLength As Long
Dim NumControlDims As Long, LongValue As Long
CtrlDimLength = Len(tmpCtrlDims)
NumControlDims = (UBound(Bytes) + 1) \ CtrlDimLength 'zero based
ReDim ControlDims(NumControlDims)
For i = 1 To NumControlDims
For j = 1 To 6
bx = (i - 1) * CtrlDimLength + (j - 1) * 4
LongValue = 0
For k = 0 To 3
LongValue = LongValue + Bytes(bx + k) * 256 ^ k
Next
Select Case j
Case 1: ControlDims(i).CtrlX = LongValue
Case 2: ControlDims(i).Left = LongValue
Case 3: ControlDims(i).Top = LongValue
Case 4: ControlDims(i).Width = LongValue
Case 5: ControlDims(i).Height = LongValue
Case 6: ControlDims(i).Ptr = LongValue
Case Else
End Select
Next
'raw data is in twips -- adjust for pixels
If i > 1 And iScaleMode = SM_Pixels Then
ControlDims(i).Left = ControlDims(i).Left / Screen.TwipsPerPixelX
ControlDims(i).Top = ControlDims(i).Top / Screen.TwipsPerPixelY
ControlDims(i).Width = ControlDims(i).Width / Screen.TwipsPerPixelX
ControlDims(i).Height = ControlDims(i).Height / Screen.TwipsPerPixelY
End If
Next
BytesToControlDims = NumControlDims
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