jwcolby
jwcolby at colbyconsulting.com
Sat Feb 21 00:40:32 CST 2009
Roughly 1.5 hours from receipt of email to back out the door to Rocky
Two classes, clsXlateFrm and clsXlateSupervisor and a simple module for initialization. Each form
loads the form class from its open event. Translation happens then and there. Strings cached to a
collection for that form and will load from the cache each time.
Understand this is just the basics, no fancy error handling or interface around the translation.
The important thing for me is to have the code for the system in a known place to add functionality
(additional properties such as tool tip etc.) should there ever be a need. Neatly organized, easy
to understand, fast, efficient, easy to program.
'---------------------------------------------------------------------------------------
' Module : clsXlateFrm
' Author : jwcolby
' Date : 2/21/2009
' Purpose : This class loads all of the phrase strings into a collection for a single form
' the first time the form loads, keyed on control name. It ignores control
' names not in the language table.
'
' It then uses those strings in the collection to translate the form.
' The second and subsequent times the form loads, the class already has the
' strings in the collection so the collection load does not happen again (cached)
' and the translation happens from the collection.
'---------------------------------------------------------------------------------------
Const cstrModule As String = "clsXlateFrm"
Option Compare Database
Option Explicit
Private mcolPhrase As Collection
Private mstrName As String
Private mstrLanguageFldName As String
Private Sub Class_Initialize()
Set mcolPhrase = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolPhrase = Nothing
End Sub
'---------------------------------------------------------------------------------------
' Procedure : mInit
' Author : jwcolby
' Date : 2/21/2009
' Purpose : Called the first time the form loads. Loads the translation phrases from the table
' and translates the form.
'---------------------------------------------------------------------------------------
'
Function mInit(lfrm As Form, lstrLanguageFldName As String)
mstrName = lfrm.Name
mstrLanguageFldName = lstrLanguageFldName
'
'If nothing in the collection then load the collection
'
If Not mcolPhrase.Count Then
mLoadColPhrase
End If
'
'Now translate the form
'
mXlateFrm lfrm
End Function
Property Get pName() As String
pName = mstrName
End Property
Function colPhrase() As Collection
Set colPhrase = mcolPhrase
End Function
'---------------------------------------------------------------------------------------
' Procedure : mXlateFrm
' Author : jwcolby
' Date : 2/21/2009
' Purpose : This function trnaslates the form. By the time this function is called the
' collection already contains all of the translation strings keyed by the
' control name. All it has to do is attempt to index into the collection
' using each control name. If there is something in the collection for that
' control name then the string is returned from the collection and placed in
' the control property.
'
' if nothing there, the error is ignored and the next control is tried.
'---------------------------------------------------------------------------------------
'
Function mXlateFrm(frm As Form)
Dim ctl As Control
On Error GoTo Err_mXlateFrm
'
'Check every control on the form
'Expand this case to add new control types.
For Each ctl In frm.Controls
Select Case ctl.ControlType
Case acLabel
'
'Try to get a translation phrase from the collection
'Any errors will be ignored
ctl.Caption = mcolPhrase(ctl.Name)
Case acCommandButton
ctl.Caption = mcolPhrase(ctl.Name)
Case Else
End Select
Next ctl
Exit_mXlateFrm:
On Error Resume Next
Exit Function
Err_mXlateFrm:
Select Case Err
Case 0 '.insert Errors you wish to ignore here
Resume Next
Case 5 'Control name not in translation table, ignore the error
Resume Next
Case Else '.All other errors will trap
Beep
MsgBox Err.Number & ":" & Err.Description
Resume Exit_mXlateFrm
End Select
Resume 0 '.FOR TROUBLESHOOTING
End Function
'---------------------------------------------------------------------------------------
' Procedure : mLoadColPhrase
' Author : jwcolby
' Date : 2/21/2009
' Purpose : Loads the translation phrase strings out of the table for one form
' Builds a query dynamically based on the form name and the translation
' language field name
'---------------------------------------------------------------------------------------
'
Private Function mLoadColPhrase()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strSQL As String
On Error GoTo Err_mLoadColPhrase
'
'Dynamically build the query to pull the translation strings for a specific form and language
'
strSQL = "SELECT fldLanguageForm, fldLanguageControl, " & mstrLanguageFldName & " " & _
"FROM [tblLanguage-Controls] " & _
"WHERE ((([tblLanguage-Controls].fldLanguageForm)='" & mstrName & "'));"
Set db = CurrentDb
Set rst = db.OpenRecordset(strSQL)
With rst
While Not .EOF
'
'Drop all phrases found into the phrase collection
'Keyed on the control name fldLanguageControl
'
mcolPhrase.Add .Fields(mstrLanguageFldName).Value, .Fields("fldLanguageControl").Value
.MoveNext
Wend
End With
Exit_mLoadColPhrase:
On Error Resume Next
Exit Function
Err_mLoadColPhrase:
Select Case Err
Case 0 '.insert Errors you wish to ignore here
Resume Next
Case Else '.All other errors will trap
Beep
MsgBox Err.Number & ":" & Err.Description
Resume Exit_mLoadColPhrase
End Select
Resume 0 '.FOR TROUBLESHOOTING
End Function
Option Compare Database
Option Explicit
Private mcolClsXlateFrm As Collection
Private Sub Class_Initialize()
Set mcolClsXlateFrm = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolClsXlateFrm = Nothing
End Sub
'---------------------------------------------------------------------------------------
' Procedure : mTranslateFrm
' Author : jwcolby
' Date : 2/21/2009
' Purpose : Performs the translation for one form passed in.
'---------------------------------------------------------------------------------------
'
Function mTranslateFrm(lfrm As Form, lstrLanguageFldName As String)
Dim lclsXlateFrm As clsXlateFrm
On Error GoTo Err_mTranslateFrm
On Error Resume Next
'
'Try to get an instance of the clsXlateFrm from the collection for this form
'
Set lclsXlateFrm = mcolClsXlateFrm(lfrm.Name)
If Err Then
'
'If that fials then this is the first time so perform the initialize
'
Set lclsXlateFrm = New clsXlateFrm
'
'Now that we have an instance for this form perform the load and translation
'
lclsXlateFrm.mInit lfrm, lstrLanguageFldName
'
'And save the instance to the collection for the next time
'
mcolClsXlateFrm.Add lclsXlateFrm, lfrm.Name
Else
'
'We have already loaded this form once so perform the translation
'
lclsXlateFrm.mXlateFrm lfrm
End If
Exit_mTranslateFrm:
On Error Resume Next
Exit Function
Err_mTranslateFrm:
Select Case Err
Case 0 '.insert Errors you wish to ignore here
Resume Next
Case Else '.All other errors will trap
Beep
MsgBox Err.Number & ":" & Err.Description
Resume Exit_mTranslateFrm
End Select
Resume 0 '.FOR TROUBLESHOOTING
End Function
'
'Return a pointer to colClsXlateFrm
'
Property Get colClsXlateFrm() As Collection
Set colClsXlateFrm = mcolClsXlateFrm
End Property
'---------------------------------------------------------------------------------------
' Module : basXlate
' Author : jwcolby
' Date : 2/21/2009
' Purpose : Functions to initialize, terminate and return a pointer to clsXlateSupervisor
' as well as a global variable for the translation string field name.
'---------------------------------------------------------------------------------------
Const cstrModule As String = "basXlate"
Option Compare Database
Option Explicit
Private mclsXlateSupervisor As clsXlateSupervisor
'
'Set this variable to the name of the field holding the translation language strings
'
'fldLanguageEnglish
'fldLanguageChineseComplex
'etc
'
Public mstrLanguageFldName As String
Function mXlateSupervisorInit()
If mclsXlateSupervisor Is Nothing Then
Set mclsXlateSupervisor = New clsXlateSupervisor
mstrLanguageFldName = "fldLanguageSpanish" 'Default language to English
End If
Set mXlateSupervisorInit = mclsXlateSupervisor
End Function
Function mXlateSupervisorTerm()
Set mclsXlateSupervisor = Nothing
End Function
Function cXS() As clsXlateSupervisor
Set cXS = mXlateSupervisorInit()
End Function
--
John W. Colby
www.ColbyConsulting.com