Form Backgroud colors

[Hank]

My boss wants to be able to set the background color of all forms to
one color that he selects on our Configuration form..
I'd rather not add a function to every form I have and wondered if it
could be done by going through the forms collections. Here is my code
but I need help addressing each from using a variable name. Please
help me with the syntax.

Private Sub UpdateFormColors(NewColor as long)

Dim obj As AccessObject, dbs As Object
Dim CurrentFormName As String

Set dbs = Application.CurrentProject
For Each obj In dbs.AllForms
CurrentFormName = obj.Name

' This line doesn't work - how do I use the variable name
Forms!CurrentFormName.Detail.BackColor = NewColor

Next obj

End Sub
'Should the forms be open or closed.
Hank Reed

[Lyle Fairfield]

One could write code to do this, (and I expect we will see examples of
that PDQ) but I wouldn't recommend it.
What if the common background color is the same color as the foreground
color of a control whose background is transparent?
Perhaps, instead of programming the form backcolor change you could
program your boss to find something worthwhile and sensible to do with
his/her time?

[Tim Marshall]

Lyle Fairfield wrote:

Perhaps, instead of programming the form backcolor change you could
program your boss to find something worthwhile and sensible to do with
his/her time?

What kind of a boss micromanages things to such a level, any way? What
an ass-wipe! Hank's boss, I mean, I don't mean you, Hank! 8)
--
Tim http://www.ucs.mun.ca/~tmarshal/
^o<
/#) "Burp-beep, burp-beep, burp-beep?" - Quaker Jake
/^^ "Whatcha doin?" - Ditto "TIM-MAY!!" - Me

[Hank]

Lyle,
Thanks for the keen observations about my boss. ;-)

Actually his reasons are pretty good. We have the same
database code installed at two different geographical locations but
with two different bckends. Sometimes he wants to have them both open
at the same time.
It was me who cautioned him that it would be easy to lose
track of which one he was looking at. I don't like having two things
look exactly alike when they are actually dfferent. I felt that having
a different background color for each site would keep him from getting
confused. Sometimes our job is to protect our bosses from themselves.
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.
Thanks,
Hank

[Lyle Fairfield]

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.

[Lyle Fairfield]

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

[Chuck Grimsby]

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!


On 1 Dec 2005 12:35:32 -0800, "Hank" <ha********@aol.com> wrote:

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.

--
Drive C: Error. (A)bort (R)etry (S)mack The Darned Thing

[Arno R]

"Hank" <ha********@aol.com> schreef in bericht news:11**********************@g47g2000cwa.googlegr oups.com...

Lyle,
Thanks for the keen observations about my boss. ;-)

Actually his reasons are pretty good. We have the same
database code installed at two different geographical locations but
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