Home | Contact Us | FAQ | Search & Site Map | Link to Us
Sign In | Join | Other 45 Sites in Network
Home
Discussion GroupsFormsForms ProgrammingQueriesModules / DAO / VBAReports / PrintingMacrosDatabase DesignSecurityConversionImporting / LinkingSQL Server / ADPMultiuser / NetworkingReplicationSetup / ConfigurationDeveloper ToolkitsActiveX ControlsNew UsersGeneral 1General 2
Access DirectoryToolsTutorialsUser Groups
Related Topics
SQL ServerOther DB ProductsMS OfficeMore Topics ...

MS Access Forum / General 1 / December 2005

Tip: Looking for answers? Try searching our database.

Form Backgroud colors

Thread view: 
Enable EMail Alerts  Start New Thread
Thread rating: 
Hank - 01 Dec 2005 17:18 GMT
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 - 01 Dec 2005 17:27 GMT
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 - 01 Dec 2005 19:27 GMT
> 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)
Signature

Tim    http://www.ucs.mun.ca/~tmarshal/
^o<
/#) "Burp-beep, burp-beep, burp-beep?" - Quaker Jake
/^^ "Whatcha doin?" - Ditto  "TIM-MAY!!" - Me

Hank - 01 Dec 2005 20:35 GMT
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 - 01 Dec 2005 22:16 GMT
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 - 01 Dec 2005 22:39 GMT
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 - 01 Dec 2005 23:03 GMT
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

Arno R - 01 Dec 2005 23:58 GMT
> 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
 
Sign In
Join
My Latest Posts
My Monitored Threads
My Blog
My Photo Gallery
My Profile
My Homepage

Start New Thread
Enable EMail Alerts
Rate this Thread



©2008 Advenet LLC   Privacy Policy - Terms of Use
This website includes both content owned or controlled by Advenet as well as content owned or controlled by third parties.