Option Compare Database
Option Explicit
Private booDebug As Boolean
Private Sub SetDebug()
booDebug = False
End Sub
Public Sub SetDefaultColumnInfo(frm As Form)
On Error GoTo err
SetDebug
Dim booPercentage As Boolean
Dim strArray() As String
Dim i As Integer
Dim strDummy As String
strArray = Split(frm.Tag, ";")
For i = LBound(strArray) To UBound(strArray)
If Left(strArray(i), 4) = "RowH" Then
If Right(strArray(i), 1) = "%" Then
strDummy = Right(strArray(i), Len(strArray(i)) - 5)
strDummy = Left(strDummy, Len(strDummy) - 1)
frm.RowHeight = CDbl("." & strDummy) * frm.InsideHeight
Else
frm.RowHeight = CInt(Right(strArray(i), Len(strArray(i)) - 5))
End If
End If
If Left(strArray(i), 5) = "FontH" Then
frm.DatasheetFontHeight = CInt(Right(strArray(i), Len(strArray(i)) - 6))
End If
Next
Dim ctl As Control
Dim lngW As Long
lngW = frm.InsideWidth - 2 * 270 '270 for the recordselectors and scroll bar
For Each ctl In frm.Controls
Select Case ctl.ControlType
Case acCheckBox, acComboBox, acTextBox
strArray = Split(ctl.Tag, ";")
For i = LBound(strArray) To UBound(strArray)
Select Case Left(strArray(i), 2)
Case "H="
If Right(strArray(i), 1) = "1" Then ctl.ColumnHidden = True
If Right(strArray(i), 1) = "0" Then ctl.ColumnHidden = False
Case "O="
ctl.ColumnOrder = Right(strArray(i), Len(strArray(i)) - 2)
Case "W="
If Right(strArray(i), 1) = "%" Then
'this must be done at the end since it is a percentage
booPercentage = True
Else
lngW = lngW - Right(strArray(i), Len(strArray(i)) - 2)
ctl.ColumnWidth = Right(strArray(i), Len(strArray(i)) - 2)
End If
Case Else
If booDebug Then Debug.Print "unhandled case: " & strArray(i)
End Select
Next
Case acLabel
Case Else
If booDebug Then Debug.Print "unhandled case: " & ctl.ControlType
End Select
Next
If booPercentage Then DoItAgain frm, lngW
Exit Sub
err:
If booDebug Then Debug.Print "SetDefaultColumnInfo " & err.Number & ": " & err.Description
End Sub
Private Sub DoItAgain(frm As Form, lngW As Long)
On Error GoTo err
Dim strArray() As String
Dim i As Integer
Dim strDummy As String
Dim ctl As Control
For Each ctl In frm.Controls
Select Case ctl.ControlType
Case acCheckBox, acComboBox, acTextBox
strArray = Split(ctl.Tag, ";")
For i = LBound(strArray) To UBound(strArray)
Select Case Left(strArray(i), 2)
Case "W="
If Right(strArray(i), 1) = "%" Then
If InStr(1, ctl.Tag, "H=1") Then GoTo skip
strDummy = Left(strArray(i), Len(strArray(i)) - 1)
strDummy = Right(strDummy, Len(strDummy) - 2)
ctl.ColumnWidth = CDbl("." & strDummy) * lngW
skip:
End If
End Select
Next
Case acLabel
Case Else
If booDebug Then Debug.Print "unhandled case: " & ctl.ControlType
End Select
Next
Exit Sub
err:
If booDebug Then Debug.Print "DoItAgain: " & err.Number & ": " & err.Description
End Sub
Public Sub SaveColumnInfo(frm As Form)
On Error GoTo err
SetDebug
Dim strTableName As String
strTableName = "tbl" & frm.Name
If Not TableExists(strTableName) Then CreateColumnInfoTable frm
Dim db As Database
Dim rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset(strTableName)
rst.MoveFirst
rst.Edit
Dim ctl As Control
For Each ctl In frm.Controls
Select Case ctl.ControlType
Case acCheckBox, acComboBox, acTextBox
rst(ctl.Name & "H") = ctl.ColumnHidden
rst(ctl.Name & "O") = ctl.ColumnOrder
rst(ctl.Name & "W") = ctl.ColumnWidth
Case acLabel
Case Else
If booDebug Then Debug.Print "unhandled case: " & ctl.ControlType
End Select
Next
rst("RowH") = frm.RowHeight
rst("FontH") = frm.DatasheetFontHeight
rst.Update
clean:
On Error Resume Next
rst.Close
Set rst = Nothing
Set db = Nothing
Exit Sub
err:
If err.Number = 3021 Then 'no current record
rst.AddNew
rst.Update
rst.MoveFirst
Resume Next
Else
If booDebug Then Debug.Print "SaveColumnInfo: " & err.Number & " " & err.Description
Resume clean
End If
End Sub
Public Sub LoadColumnInfo(frm As Form)
On Error GoTo err
SetDebug
Dim booDeleteTable As Boolean
Dim strTableName As String
strTableName = "tbl" & frm.Name
If Not TableExists(strTableName) Then CreateColumnInfoTable frm
Dim db As Database
Dim rst As DAO.Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset(strTableName)
Dim ctl As Control
For Each ctl In frm.Controls
Select Case ctl.ControlType
Case acCheckBox, acComboBox, acTextBox
ctl.ColumnOrder = rst(ctl.Name & "O")
ctl.ColumnWidth = rst(ctl.Name & "W")
ctl.ColumnHidden = rst(ctl.Name & "H")
Case acLabel
Case Else
If booDebug Then Debug.Print "unhandled case: " & ctl.ControlType
End Select
Next
frm.RowHeight = rst("RowH")
frm.DatasheetFontHeight = rst("FontH")
clean:
On Error Resume Next
rst.Close
Set rst = Nothing
Set db = Nothing
If booDeleteTable Then
DoCmd.DeleteObject acTable, strTableName
db.TableDefs.Refresh
RefreshDatabaseWindow
End If
Exit Sub
err:
If booDebug Then Debug.Print "LoadColumnInfo: " & err.Number & ": " & err.Description
If err.Number = 3265 Then booDeleteTable = True 'item not found in this collection, delete table to be rebuild later
Resume clean
End Sub
Private Function TableExists(strName As String) As Boolean
On Error GoTo err
TableExists = IsObject(CurrentDb.TableDefs(strName))
err:
End Function
Private Sub CreateColumnInfoTable(frm As Form)
On Error GoTo err
Dim db As Database
Dim tbl As TableDef
Dim fld As Field
Dim ctl As Control
Set db = CurrentDb
Set tbl = db.CreateTableDef("tbl" & frm.Name)
For Each ctl In frm.Controls
Select Case ctl.ControlType
Case acCheckBox, acComboBox, acTextBox
Set fld = tbl.CreateField(ctl.Name & "O", dbInteger)
tbl.Fields.Append fld
Set fld = tbl.CreateField(ctl.Name & "W", dbLong)
tbl.Fields.Append fld
Set fld = tbl.CreateField(ctl.Name & "H", dbInteger)
tbl.Fields.Append fld
Case acLabel
Case Else
If booDebug Then Debug.Print "unhandled case: " & ctl.ControlType
End Select
Next
Set fld = tbl.CreateField("RowH", dbLong)
tbl.Fields.Append fld
Set fld = tbl.CreateField("FontH", dbInteger)
tbl.Fields.Append fld
db.TableDefs.Append tbl
db.TableDefs.Refresh
RefreshDatabaseWindow
clean:
On Error Resume Next
Set db = Nothing
Set tbl = Nothing
Set fld = Nothing
Exit Sub
err:
If booDebug Then Debug.Print "CreateColumnInfoTable: " & err.Number & " " & err.Description
Resume clean
End Sub
