VBLM_RTB_D.bas

'VBLM_RTB_D_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: Yes

 

'Write Language Selection to Registry: No

 

'Read Language Selection from Registry: No

 

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

'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

 

'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

 

'dimset database binary file header

Type tagBDDHeader

Version As Long 

NumDimSets As Long 

DimSetSize As Long 

NumProjects As Long 

MaxControlContainers As Long 

DataOffset As Long 

End Type

 

'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 from the string

'fetching routine to the dim fetching routine

Dim mlSelectedLanguage As Long

 

'mlDimSetOffset is the offset of the dimset info in the database file

Dim mlDimSetOffset 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 

 

'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 

 

'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

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

 

'Handle is used as the initialization flag

 

If mlDatabaseHandle = 0 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 

 

'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 

Get #mlDatabaseHandle, , mlDimSetOffset 

 

'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 

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 

 

'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 and there are no dimsets, close the file

'otherwise we need to keep it open

If cOPTIMIZATION = cOPTIMIZE_FOR_SPEED And mlDimSetOffset = 0 Then Close mlDatabaseHandle 

 

'restore the original cursor state

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 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 VBLM_GetDimensions(PrjX As Long, FileX As Long, CtrlDims() As tagControlDims, iScaleMode As Integer) As Long

 

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

' LOCAL DECLARATIONS

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

'SM_Pixels = Pixel ScaleMode Value

 

Const SM_Pixels = 3 

 

' STATIC VARIABLES

 

'bInit = initialization flag

Static bInit As Boolean 

 

'lProjectFileOffsets() hold dimension location data

Static lProjectFileOffsets() As Long 

 

'BDDHeader

Static BDDHeader As tagBDDHeader 

 

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

' TRANSIENT VARIABLES USED ONLY ON FIRST CALL (INITIALIZATION)

'

'lNumControls = number of controls with stored dims for the requested file

Dim lNumControls As Long 

 

'li,lj = for-next counter variables

 

Dim li As Long, lj As Long 

 

'lPreviousMousePointer = MousePointer Cache Variable

Dim lPreviousMousePointer As Long 

 

'lProjectOffsets() = location in a dimset of beginning of each project

Dim lProjectOffsets() As Long 

 

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

' EXECUTABLE CODE BEGINS HERE

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

'INITIALIZATION CODE: EXECUTES ONLY ON FIRST CALL

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

 

'cache the current cursor and look busy

lPreviousMousePointer = Screen.MousePointer 

Screen.MousePointer = vbHourglass 

 

'open file if necessary (it should be open)

If mlDatabaseHandle = False Then OpenDatabaseFile 

 

'initialization code -- only executes on first call

If bInit = False Then 

 

'Default Error handling

On Error GoTo RTSD_Error 

 

If mlDimSetOffset = 0 Then 

Get #mlDatabaseHandle, 1, mlDimSetOffset 

Get #mlDatabaseHandle, , mlDimSetOffset 

End If 

 

'get the file header

Get #mlDatabaseHandle, mlDimSetOffset, BDDHeader 

 

ReDim lProjectFileOffsets(BDDHeader.NumProjects, BDDHeader.MaxControlContainers) 

 

'now fill the offset array with pointers to the db location of dim data for each prj file

'this loc is WITHIN each dimset, and will be offset by the dimset# and size

ReDim lProjectOffsets(BDDHeader.NumProjects) 

For li = 1 To BDDHeader.NumProjects 

Get #mlDatabaseHandle, , lProjectOffsets(li) 

Next 

 

For li = 1 To BDDHeader.NumProjects 

Seek mlDatabaseHandle, lProjectOffsets(li) 

Get #mlDatabaseHandle, , lProjectFileOffsets(li, 0) 'number of files in project 

For lj = 1 To lProjectFileOffsets(li, 0) 

Get #mlDatabaseHandle, , lProjectFileOffsets(li, lj) 

Next 

Next 

 

bInit = True 

 

End If 

 

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

' END OF INITIALIZATION CODE

' FOLLOWING CODE EXECUTES ON ALL CALLS TO RETURN THE STRING

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

 

'seek and read dim data from disk

li = lProjectFileOffsets(PrjX, FileX) + (mlSelectedLanguage - 1) * BDDHeader.DimSetSize 

 

Get #mlDatabaseHandle, li, lNumControls 

 

ReDim CtrlDims(lNumControls) 

 

For li = 1 To lNumControls 

Get #mlDatabaseHandle, , CtrlDims(li) 

'raw data is in twips -- adjust for pixels 

If li > 1 And iScaleMode = SM_Pixels Then 

CtrlDims(li).Left = CtrlDims(li).Left / Screen.TwipsPerPixelX 

CtrlDims(li).Top = CtrlDims(li).Top / Screen.TwipsPerPixelY 

CtrlDims(li).Width = CtrlDims(li).Width / Screen.TwipsPerPixelX 

CtrlDims(li).Height = CtrlDims(li).Height / Screen.TwipsPerPixelY 

End If 

Next 

 

'restore the original cursor state

Screen.MousePointer = lPreviousMousePointer 

 

'and return the # of control dimsets returned

VBLM_GetDimensions = lNumControls 

 

Exit Function 

 

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

' END OF MAIN FUNCTION CODE

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

 

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

' default error handler

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

RTSD_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

 

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