One could put code in the load or open event of all forms to change the
backcolor of the detail section of the form.
If one has a million froms this could be quite a chore. I looked up my
"Standardize Forms" Code to see if this could be adapted to do this and
I believe it can. But the code was written in the days of Access 97
and needs some revision to work in Access >= 2000. That will take a
little "spare time" which may or may not happen soon.
In the meantime here is another suggestion. I change the application
title sometimes so that users have some information in front of them
about what they are working on. The code is very simple and they don't
have to remember what red stands for; the words are right there:
Option Explicit
Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String) As Long
Public Sub DisplayAppTitle(ByVal Title As String)
SetWindowText hWndAccessApp, Title
End Sub
Sub test()
DisplayAppTitle "Patagonia"
End Sub
Assuming your backends has some distinguishing data that could be
queried on application open and used to specify this app title which
would be always there.
A little later
Well if you HAVE to revise a million forms you might be able to modify
this code to do it; as I mentioned previously it was written for AC97
and so many there are UDFs in it which are now redundant. In 1998 I
tested it a lot but in 2005 I've tested it ONLY once. So if you plan to
use it, please, do so on a throw away copy of your db until you feel
safe about it.
Public Sub StandardizeTheForms()
Dim BaseName As String
Dim Ctl As Control
Dim Frm As Form
Dim Increment As Long
Dim NewIterator As Long
Dim NewName As String
Dim NewNames As New Collection
Dim Obj As AccessObject
Dim OldIterator As Long
Dim OldName As String
Dim OldNames As New Collection
Dim Old_Name As String
Dim Old_Names As New Collection
Dim Prefix As String
Dim StatusBarVisible As Boolean
Dim Substance As String
On Error Resume Next
StatusBarVisible = GetOption("Show Status Bar")
SetOption "Show Status Bar", True
Echo False
For Each Obj In Application.CurrentProject.AllForms
With Obj
DoCmd.Close acForm, .FullName
DoCmd.OpenForm .FullName, acDesign
Set Frm = Forms(.FullName)
With Frm
.HasModule = True
For Each Ctl In .Controls
With Ctl
Prefix = ""
OldName = .Name
Old_Name = strTran(OldName, " ", "_")
SysCmd acSysCmdSetStatus, "Processing " &
OldName & " ..."
Select Case .ControlType
Case acLabel
Prefix = "lbl"
Substance = .Caption
Case acTextBox
Prefix = "txt"
Substance = .ControlSource
If Len(Substance) = 0 Then Substance =
OldName
Case acComboBox
Prefix = "cbo"
Substance = .ControlSource
If Len(Substance) = 0 Then Substance =
OldName
Case acListBox
Prefix = "lst"
Substance = .ControlSource
If Len(Substance) = 0 Then Substance =
OldName
Case acCheckBox
Prefix = "chk"
Substance = .ControlSource
Case acSubform
Prefix = "sub"
Substance = .SourceObject
Case acCommandButton
Prefix = "cmd"
Substance = .Caption
Case acImage
Prefix = "img"
Substance = .Name
End Select
If Len(Prefix) <> 0 Then
If Len(Substance) = 0 Then Substance =
OldName
Substance = AlphaNumericOnly(Substance)
BaseName = Prefix &
Left(AlphaNumericOnly(Substance), 249)
Do While Mid(BaseName, 1, 3) =
Mid(BaseName, 4, 3)
BaseName = Mid(BaseName, 4)
Loop
Increment = 0
Do
Err = 0
.Name = BaseName
Increment = Increment + 1
BaseName = BaseName & CStr(Increment)
Loop Until Err = 0
NewName = .Name
With OldNames
If .Count = 0 Then
.Add OldName
Old_Names.Add Old_Name
NewNames.Add NewName
Else
For OldIterator = 1 To .Count
If Len(OldName) <
Len(.Item(OldIterator)) Then
Exit For
End If
Next OldIterator
If OldIterator > .Count Then
.Add OldName
Old_Names.Add Old_Name
NewNames.Add NewName
Else
.Add OldName, , OldIterator
Old_Names.Add Old_Name, ,
OldIterator
NewNames.Add NewName, ,
OldIterator
End If
End If
End With
End If
End With
Next Ctl
With NewNames
For NewIterator = 1 To .Count
NewName = .Item(NewIterator)
OldName = OldNames(NewIterator)
SysCmd acSysCmdSetStatus, "Renaming " & OldName
& " to " & NewName & " ..."
Old_Name = Old_Names(NewIterator)
FindandReplaceinModule Frm.Module, OldName,
NewName
FindandReplaceinModule Frm.Module, Old_Name,
NewName
With OldNames
If .Count > NewIterator Then
For OldIterator = NewIterator + 1 To
.Count
OldName =
strTran(.Item(OldIterator), OldName, NewName)
If OldName <> .Item(OldIterator)
Then
.Remove OldIterator
.Add OldName, , , OldIterator -
1
End If
Old_Name =
strTran(.Item(OldIterator), Old_Name, NewName)
If Old_Name <> .Item(OldIterator)
Then
.Remove OldIterator
.Add Old_Name, , , OldIterator
- 1
End If
Next OldIterator
End If
End With
Next NewIterator
End With
Set NewNames = Nothing
Set OldNames = Nothing
Set Old_Names = Nothing
SysCmd acSysCmdSetStatus, "Modifying Properties" & "
..."
.MaxButton = False
.AutoCenter = True
.AutoResize = True
SysCmd acSysCmdSetStatus, "Modifying Code" & " ..."
ModifyCode .Module
DeleteDoubleBlankLinesinModule .Module
OrderControls Frm
DoCmd.Close acForm, .Name, acSaveYes
End With
End With
Next Obj
Set Ctl = Nothing
Set Frm = Nothing
SysCmd acSysCmdClearStatus
SetOption "Show Status Bar", True
Echo True
End Sub
Private Sub ModifyCode(ByRef Mdl As Module)
Const EndColumn As Byte = 255
Const ProcCode _
= " With DoCmd" & vbCrLf _
& " .Restore" & vbCrLf _
& " .RunCommand acCmdSizeToFitForm" & vbCrLf _
& " End With"
Const ProcName As String = "Form_Load"
Const StartColumn As Byte = 0
Const SubPrefix As String = "Private Sub "
Const SubSuffix As String = "End Sub"
Const Trigger As String = "RunCommand acCmdSizeToFitForm"
Dim EndLine As Long
Dim StartLine As Long
On Error Resume Next
With Mdl
Err = 0
StartLine = .ProcBodyLine(ProcName, vbext_pk_Proc)
' err 35 returned when proc can't be found
If Err = 35 Then
StartLine = .CountOfLines + 1
.InsertLines StartLine, SubSuffix
.InsertLines StartLine, ProcCode
.InsertLines StartLine, SubPrefix & ProcName
.InsertLines StartLine, ""
Else
StartLine = .ProcBodyLine(ProcName, vbext_pk_Proc)
EndLine = StartLine + .ProcCountLines(ProcName,
vbext_pk_Proc) - 1
If Not _
(.Find(Trigger, StartLine + 1, _
StartColumn, EndLine - 1, EndColumn)) Then
.InsertLines EndLine - 1, ProcCode
End If
End If
End With
End Sub
Private Sub DeleteDoubleBlankLinesinModule(ByRef Mdl As Module)
Dim Line As Long
On Error Resume Next
With Mdl
For Line = .CountOfLines To 2 Step -1
If Len(AlphaNumericOnly(.Lines(Line - 1, 2))) = 0 Then
.DeleteLines Line, 1
Next Line
End With
End Sub
Private Sub OrderControls(ByRef Frm As Form)
Dim Col As New Collection
Dim ColIterator As Long
Dim CtlInCol As Control
Dim CtlInForm As Control
Dim CtlName As String
Dim Prp As Property
Dim VarCtl As Variant
On Error Resume Next
For Each CtlInForm In Frm.Controls
SysCmd acSysCmdSetStatus, "Processing " & CtlInForm.Name & "
..."
With Col
If .Count = 0 Then
.Add CtlInForm
Else
For ColIterator = 1 To .Count
Set CtlInCol = .Item(ColIterator)
If (CtlInForm.Top < CtlInCol.Top) _
Or ((CtlInForm.Top = CtlInCol.Top) _
And (CtlInForm.Left <= CtlInCol.Left)) Then
.Add CtlInForm, , ColIterator
Exit For
End If
Next ColIterator
End If
If ColIterator = .Count + 1 Then .Add CtlInForm
End With
Next CtlInForm
For Each VarCtl In Col
Set CtlInCol = VarCtl
With CtlInCol
CtlName = .Name
Set CtlInForm = CreateControl(Frm.Name, .ControlType,
.Section, , , 0, 0, 1, 1)
For Each Prp In CtlInCol.Properties
With Prp
CtlInForm.Properties(.Name) = .Value
End With
Next Prp
End With
CtlInForm.Name = "Tmp" & CtlName
DeleteControl Frm.Name, CtlName
CtlInForm.Name = CtlName
Next VarCtl
Set CtlInCol = Nothing
Set Col = Nothing
Set CtlInForm = Nothing
Set Prp = Nothing
End Sub
Private Function strTran( _
ByVal ReplaceIn As String, _
ByVal ReplaceWhat As String, _
ByVal ReplaceWith As String, _
Optional ByVal CompareMethod As Long = vbTextCompare) As String
Dim Position As Long
On Error Resume Next
Position = InStr(1, ReplaceIn, ReplaceWhat, CompareMethod)
Do While Position <> 0
strTran = strTran & Left(ReplaceIn, Position - 1) & ReplaceWith
ReplaceIn = Mid(ReplaceIn, Position + Len(ReplaceWhat))
Position = InStr(1, ReplaceIn, ReplaceWhat, CompareMethod)
Loop
strTran = strTran & ReplaceIn
End Function
Private Function AlphaNumericOnly(ByVal s As String) As String
Dim a() As Byte
Dim b As Byte
Dim v As Variant
On Error Resume Next
a = StrConv(s, vbFromUnicode)
For Each v In a
If v > 47 And v < 58 Then
AlphaNumericOnly = AlphaNumericOnly & Chr(v)
Else
b = v Or 32
If b > 96 And b < 123 Then AlphaNumericOnly =
AlphaNumericOnly & Chr(v)
End If
Next v
End Function
Private Sub FindandReplaceinModule( _
ByRef Mdl As Module, _
ByVal ReplaceWhat As String, _
ByVal ReplaceWith As String)
Dim EndColumn As Long
Dim EndLine As Long
Dim StartColumn As Long
Dim StartLine As Long
Dim strLine As String
Dim strLeft As String
Dim strRight As String
On Error Resume Next
If (Len(ReplaceWith) = 0) Or (Len(ReplaceWhat) = 0) Or (ReplaceWhat
= ReplaceWith) Then Exit Sub
With Mdl
Do While .Find(ReplaceWhat, StartLine, StartColumn, EndLine,
EndColumn, True)
strLine = .Lines(StartLine, 1)
strLeft = Mid$(strLine, 1, StartColumn - 1)
strRight = Mid$(strLine, EndColumn)
strLine = strLeft + ReplaceWith + strRight
.ReplaceLine StartLine, strLine
StartColumn = StartColumn + Len(ReplaceWith)
EndLine = 0
EndColumn = 0
Loop
.Application.RunCommand acCmdCompileLoadedModules
End With
End Sub
I'm not sure I'd use a configuration table for this. At least, not
one that was user modifiable! It's *really* easy for a user to change
the code to something that makes text disappear, or do other weird
things.
But if you want to do this, in the form load event (and yes, you'll
have to do this in every form), look at the path (or connect
statement) where the backend is, and use the Me.Detail.Backcolor
statement to change the background color of the form.
Below is an example using a SQL Server backend:
Dim mydb As DAO.Database
Dim myrst As DAO.Recordset
Const strSQL As String = _
"SELECT Connect " & _
"FROM MSysObjects " & _
"WHERE [Name]='SomeBackendTable'"
Set mydb = CurrentDb
Set myrst = mydb.OpenRecordset(strSQL, , dbOpenForwardOnly)
If Not myrst.EOF And Not myrst.BOF Then
Select Case InStr(myrst.Fields("Connect"), _
"SomeServerName")
Case 0
Me.Detail.BackColor = -2147483633
Case Else
Me.Detail.BackColor = 16744448
End Select
End If
myrst.Close
Set myrst = Nothing
Set mydb = Nothing
Obviously, you'll want to adjust the "SomeBackendTable" and
"SomeServerName" to be a table and server in your organization, as
well as setting the BackColors to be something someone would actually
_want_ to use!
> Where I need help is changing the backgound color of all
>forms though some itterative method when a new color is selected. My
>first (dumb) idea was to have a function on each form that looked up
>the color from the Configuration Table. Nahhhh.
> I'm using Access 2000.

Signature
Drive C: Error. (A)bort (R)etry (S)mack The Darned Thing
> Lyle,
> Thanks for the keen observations about my boss. ;-)
[quoted text clipped - 3 lines]
> with two different bckends. Sometimes he wants to have them both open
> at the same time.
Why not use a nice picture of the geografical location (CountryMap?) as background for all the forms?
(Depends on the backend of course...)
Sub PictureInAllForms() 'just adapted this, not tested ...
Dim db As Database
Dim cnt As Container
Dim doc As Document
Dim strForm As String
Dim frm As Form
Set db = CurrentDb()
For Each cnt In db.Containers
If cnt.Name = "Forms" Then
For Each doc In cnt.Documents
strForm = doc.Name
DoCmd.OpenForm strForm, acDesign
Set frm = Forms(strForm)
'frm.PictureTiling = True 'depends if you need this. If so you need it only once
frm.Picture = "C:\Program Files\Microsoft Office2000\Office\Bitmaps\MyNice.gif"
DoCmd.Close acForm, strForm, acSaveYes
Next doc
End If
Set db = Nothing
Set cnt = Nothing
Set doc = Nothing
Set frm = Nothing
End Sub
Arno R