How to loop this code through all control captions (1 Viewer)

[torz]

Hi guys,

I've tried a few different things which didnt seem to work, the closest that I got was looping through all the controls, but it would display the font selector for every control. I'd like to have the button to open the font selector and then once selected it applies to all captions on the current form.

1st module

Option Compare Database
Option Explicit

' Original Code by Terry Kreft
' Modified by Stephen Lebans
' Contact Stephen@lebans.com


'************  Code Start  ***********
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Const LF_FACESIZE = 32

Private Const FW_BOLD = 700

Private Const CF_APPLY = &H200&
Private Const CF_ANSIONLY = &H400&
Private Const CF_TTONLY = &H40000
Private Const CF_EFFECTS = &H100&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_NOSIZESEL = &H200000
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOVERTFONTS = &H1000000
Private Const CF_OEMTEXT = 7
Private Const CF_PRINTERFONTS = &H2
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_SCREENFONTS = &H1
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_SHOWHELP = &H4&
Private Const CF_USESTYLE = &H80&
Private Const CF_WYSIWYG = &H8000
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS

Public Const LOGPIXELSY = 90

Public Type FormFontInfo
  Name As String
  Weight As Integer
  Height As Integer
  UnderLine As Boolean
  Italic As Boolean
  Color As Long
End Type

Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type FONTSTRUC
  lStructSize As Long
  hwnd As Long
  hdc As Long
  lpLogFont As Long
  iPointSize As Long
  Flags As Long
  rgbColors As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
  hInstance As Long
  lpszStyle As String
  nFontType As Integer
  MISSING_ALIGNMENT As Integer
  nSizeMin As Long
  nSizeMax As Long
End Type

Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _
(pChoosefont As FONTSTRUC) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" _
  (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" _
  (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long


Private Function MulDiv(In1 As Long, In2 As Long, In3 As Long) As Long
Dim lngTemp As Long
  On Error GoTo MulDiv_err
  If In3 <> 0 Then
    lngTemp = In1 * In2
    lngTemp = lngTemp / In3
  Else
    lngTemp = -1
  End If
MulDiv_end:
  MulDiv = lngTemp
  Exit Function
MulDiv_err:
  lngTemp = -1
  Resume MulDiv_err
End Function
Private Function ByteToString(aBytes() As Byte) As String
  Dim dwBytePoint As Long, dwByteVal As Long, szOut As String
  dwBytePoint = LBound(aBytes)
  While dwBytePoint <= UBound(aBytes)
    dwByteVal = aBytes(dwBytePoint)
    If dwByteVal = 0 Then
      ByteToString = szOut
      Exit Function
    Else
      szOut = szOut & Chr$(dwByteVal)
    End If
    dwBytePoint = dwBytePoint + 1
  Wend
  ByteToString = szOut
End Function

Private Sub StringToByte(InString As String, ByteArray() As Byte)
Dim intLbound As Integer
  Dim intUbound As Integer
  Dim intLen As Integer
  Dim intX As Integer
  intLbound = LBound(ByteArray)
  intUbound = UBound(ByteArray)
  intLen = Len(InString)
  If intLen > intUbound - intLbound Then intLen = intUbound - intLbound
For intX = 1 To intLen
ByteArray(intX - 1 + intLbound) = Asc(Mid(InString, intX, 1))
Next
End Sub


Public Function DialogFont(ByRef f As FormFontInfo) As Boolean
  Dim LF As LOGFONT, FS As FONTSTRUC
  Dim lLogFontAddress As Long, lMemHandle As Long

  LF.lfWeight = f.Weight
  LF.lfItalic = f.Italic * -1
  LF.lfUnderline = f.UnderLine * -1
  LF.lfHeight = -MulDiv(CLng(f.Height), GetDeviceCaps(GetDC(hWndAccessApp), LOGPIXELSY), 72)
  Call StringToByte(f.Name, LF.lfFaceName())
  FS.rgbColors = f.Color
  FS.lStructSize = Len(FS)

  lMemHandle = GlobalAlloc(GHND, Len(LF))
  If lMemHandle = 0 Then
    DialogFont = False
    Exit Function
  End If

  lLogFontAddress = GlobalLock(lMemHandle)
  If lLogFontAddress = 0 Then
    DialogFont = False
    Exit Function
  End If

  CopyMemory ByVal lLogFontAddress, LF, Len(LF)
  FS.lpLogFont = lLogFontAddress
  FS.Flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
  If ChooseFont(FS) = 1 Then
    CopyMemory LF, ByVal lLogFontAddress, Len(LF)
    f.Weight = LF.lfWeight
    f.Italic = CBool(LF.lfItalic)
    f.UnderLine = CBool(LF.lfUnderline)
    f.Name = ByteToString(LF.lfFaceName())
    f.Height = CLng(FS.iPointSize / 10)
    f.Color = FS.rgbColors
    DialogFont = True
  Else
    DialogFont = False
  End If
End Function

Function test_DialogFont(ctl As Control) As Boolean
Dim frm As Form
    Dim f As FormFontInfo
    With f
      .Color = 0
      .Height = 12
      .Weight = 700
      .Italic = False
      .UnderLine = False
      .Name = "Arial"
    End With
    Call DialogFont(f)
    With f
        Debug.Print "Font Name: "; .Name
        Debug.Print "Font Size: "; .Height
        Debug.Print "Font Weight: "; .Weight
        Debug.Print "Font Italics: "; .Italic
        Debug.Print "Font Underline: "; .UnderLine
        Debug.Print "Font COlor: "; .Color
    
        ctl.FontName = .Name
        ctl.FontSize = .Height
        ctl.FontWeight = .Weight
        ctl.FontItalic = .Italic
        ctl.FontUnderline = .UnderLine
        'ctl = .Name & " - Size:" & .Height
    End With
    test_DialogFont = True
End Function
'************  Code End  ***********

2nd module

' Original Code by Terry Kreft
' Modified by Stephen Lebans
' Contact Stephen@lebans.com
' Modified by Peter De Baets
' Contact Info@PetersSoftware.com

Option Compare Database
Option Explicit
'***********  Code Start  ***********
Private Type COLORSTRUC
  lStructSize As Long
  hwnd As Long
  hInstance As Long
  rgbResult As Long
  lpCustColors As String
  Flags As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type


Private Const CC_RGBINIT = &H1
Private Const CC_FULLOPEN = &H2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_SHOWHELP = &H8
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_ANYCOLOR = &H100


Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
  (pChoosecolor As COLORSTRUC) As Long

Public Function aDialogColor(prop As Property) As Boolean
  Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long

  
  CS.lStructSize = Len(CS)
  CS.hwnd = hWndAccessApp
  CS.rgbResult = Nz(prop.Value, 0)
  CS.Flags = CC_SOLIDCOLOR Or CC_RGBINIT
  CS.lpCustColors = String$(16 * 4, 0)
  x = ChooseColor(CS)
  If x = 0 Then
    ' ERROR - use Default White
    prop = RGB(255, 255, 255) ' White
    aDialogColor = False
    Exit Function
  Else
    ' Normal processing
     prop = CS.rgbResult
  End If
  aDialogColor = True
End Function
'***********  Code End   ***********

' If you want this Function to simply Return
' the Value of the Color the user selected
' from the Dialog just change the Function
' Declaration in modColorPicker to something like:
'Public Function DialogColor(ctl As Control) As Long
' Remember to add the line of code at the
' end of the Function
'DialogColor = CS.rgbResult
' Then call it from your Form with code like:

'***Code Start
'Private Sub CmdChooseBackColor_Click()
' Pass the TextBox Control to the function
'Me.textCtl.BackColor = DialogColor(Me.textCtl)
'End Sub
Public Function xg_ChooseColor(lngDefaultColor As Long) As Long
  Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
  Dim lngRtn As Long

  
  CS.lStructSize = Len(CS)
  CS.hwnd = hWndAccessApp
  'CS.rgbResult = Nz(prop.Value, 0)
  CS.rgbResult = Nz(lngDefaultColor, 0)
  CS.Flags = CC_SOLIDCOLOR Or CC_RGBINIT
  CS.lpCustColors = String$(16 * 4, 0)
  x = ChooseColor(CS)
  If x = 0 Then
    ' ERROR - use Default White
    'prop = RGB(255, 255, 255) ' White
    lngRtn = RGB(255, 255, 255) ' White
    'aDialogColor = False
    Exit Function
  Else
    ' Normal processing
     'prop = CS.rgbResult
     lngRtn = CS.rgbResult
  End If
  xg_ChooseColor = lngRtn
End Function
'***********  Code End   ***********

' If you want this Function to simply Return
' the Value of the Color the user selected
' from the Dialog just change the Function
' Declaration in modColorPicker to something like:
'Public Function DialogColor(ctl As Control) As Long
' Remember to add the line of code at the
' end of the Function
'DialogColor = CS.rgbResult
' Then call it from your Form with code like:

'***Code Start
'Private Sub CmdChooseBackColor_Click()
' Pass the TextBox Control to the function
'Me.textCtl.BackColor = DialogColor(Me.textCtl)
'End Sub

Code for the buttons

Option Compare Database
Option Explicit

Private Sub CmdChooseBackColor_Click()
Dim lngRet As Boolean
    ' Pass the TextBox BackColor property to the function
    lngRet = aDialogColor(Me.textCtl.Properties("BackColor"))
End Sub

Private Sub CmdChooseForeColor_Click()
Dim lngRet As Boolean
    ' Pass the TextBox ForeColor property to the function
    lngRet = aDialogColor(Me.textCtl.Properties("ForeColor"))
    ' If error set ForeColor to Black
    If lngRet = False Then Me.textCtl.Properties("ForeColor") = 0
End Sub

Private Sub CmdChooseFont_Click()
Dim lngRet As Boolean
    ' Pass the TextBox Control to the function
    lngRet = test_DialogFont(Me.textCtl)
End Sub

hope its something easy that I've just been overlooking!

Thanks heaps guys!

 

[Uncle Gizmo]

I don't understand?

Please boil it down to a simple question like:-.

I tried to do X

I received error message Y at this location in the code.

 

[torz]

Ahh sorry, after reading my original post I realize how retarded it was...

So the code I found on the www in the original post has 2 problems (for me)

1. It changes the actual control and not the label/control caption which is what I need it to change.

2. It seems that it just changes one control at a time, i've managed to get it to changed all controls but it asks to select the font for every control instead of just looping through all controls with the users selection.

I've attached a sample DB and hopefully you will see what I'm trying to say on the Form1


to put is as simple as possible, I want to make 1 selection (using any of the 3 buttons) which will apply that selection to all control labels/captions throughout the form.

 

[Uncle Gizmo]

1. It changes the actual control and not the label/control caption which is what I need it to change.

I don't know if this is relevant but it might give you a way to get to the label.

MS Access – VBA – Determine a Control’s Associated Label

 

[torz]

nope, just gives object error if I use it in the Form1 loop

 

[Royce]

Use something like this

lngRet = aDialogColor(Me.txtCtrl("BackColor"))
 lngColor  = Me.txtCtrl.BackColor

' Loop through the controls, use With ctrl, whatever
...
me.MyLabel.Backcolor = lngColor

 

[JHB]

Try it now, the font change should work!

 

[torz]

Try it now, the font change should work!

Thats just about perfect jhb, I'll have a play around and see if I can get the rest of it the way I needed it... should be able to work it out *fingers crossed*

The couple of things that dont appear to work: the font changes perfectly but in the font selector the colour selection doesn't work.

The other 2 buttons still display for each control but I should be fine sorting that out using the same method you used for the font button

thanks again JHB!

 

[torz]

and everyone else of course!!!

 

[JHB]

... the font changes perfectly but in the font selector the colour selection doesn't work.

Then insert the code line marked with red:

Sub SetFont(ctl As Control)
  With f
    ctl.Controls(0).FontSize = .Height
    ctl.Controls(0).FontWeight = .Weight
    ctl.Controls(0).FontItalic = .Italic
    ctl.Controls(0).FontUnderline = .UnderLine
   [B][COLOR=Red] ctl.Controls(0).ForeColor = .Color[/COLOR][/B]
  End With
End Sub

The other 2 buttons still display for each control but I should be fine sorting that out using the same method you used for the font button

Yes I think so, else post again and tell where you've problem.

 

[torz]

Sorry, JHB... Still having problems, feel so stupid now... Can't get the other buttons to work (loop through all controls(not the labels, the actual controls I was after for the other 2 buttons))

I have not had a great deal of time to try playing around with it but I have no idea where I was going wrong.

Thanks for your efforts with the last one! hoping you can help here as well!

 

[JHB]

Ok - then try it now.

 

[torz]

thanks heaps mate!
not quite what I needed but it is close enough button which allows the changing of the font was for just labels & the other two were for the controls themselves (ultimately allowing the user to change font colour, style and size of the label but not the back colour & allowing the fore & back colours to be changed but not the font itself for the controls/fields) I think I should be able to work it out from here after comparing the 2 examples that you uploaded... Thanks again!!

 

[JHB]

You're welcome, luck with it.

 

[torz]

Hey JHB, thanks for everything so far... still having issues, and I think its because of other code running in the DB... can't upload the DB because its got some sensitive data in it now, but if you have teamviewer I'm happy to share screen and show you all the code etc if possible.

 

[JHB]

Hey JHB, thanks for everything so far... still having issues, and I think its because of other code running in the DB... can't upload the DB because its got some sensitive data in it now, but if you have teamviewer I'm happy to share screen and show you all the code etc if possible.

What issues do you've?
Make a copy of you database and replace the sensitive data with some sample data.
I don't have Teamviewer.

 

[torz]

okay think I've got it all in this copy for you

left all the modules in there and the code for one of the forms


when you click any of the 3 buttons up the top to change the forecolor / backcolor or font & color it just errors...


I'm not sure what would be easier, if it is easier for whatever they select after clicking the buttons to be saved in the user pref and I just look it up and set it on the form open, or they just select each time they want to change it...

kind of like the background color gradient... I currently have a set temp background on the form itself, but there is a user pref form where they set it and it saves, so any of the forms throughout the DB open with their color pref.

 

[JHB]

It errors because some controls doesn't have any label, therefore you've to check it first.

Sub SetFont(ctl2 As control)
  With f
    'set the control it self
    ctl2.FontSize = .Height
    ctl2.FontWeight = .Weight
    ctl2.FontItalic = .Italic
    ctl2.FontUnderline = .UnderLine
    ctl2.ForeColor = .Color
    'set the controls label
    If ctl2.Controls.Count > 0 Then
      ctl2.Controls(0).FontSize = .Height
      ctl2.Controls(0).FontWeight = .Weight
      ctl2.Controls(0).FontItalic = .Italic
      ctl2.Controls(0).FontUnderline = .UnderLine
      ctl2.Controls(0).ForeColor = .Color
    End If
  End With
End Sub


Sub SetColor(ctlMyControl As control, setForeColor As Boolean)
  If setForeColor Then
    'set the control it self
    ctlMyControl.ForeColor = cs.rgbResult
    'set the controls label
    If ctlMyControl.Controls.Count > 0 Then
      ctlMyControl.Controls(0).ForeColor = cs.rgbResult
    End If
  Else
    ctlMyControl.BackColor = cs.rgbResult
    'set the controls label
    If ctlMyControl.Controls.Count > 0 Then
      ctlMyControl.Controls(0).ForeColor = cs.rgbResult
    End If
  End If
End Sub

I'm not sure what would be easier, if it is easier for whatever they select after clicking the buttons to be saved in the user pref and I just look it up and set it on the form open, or they just select each time they want to change it...

Ask your user what they prefer!

 

[torz]

Works great thank you!