Article ID: 197127
Article Last Modified on 3/7/2005
Option Explicit
Private UseFont As String
Private UseFontSize As Long
Public Property Let MyFont(NewFont As String)
Dim Ctrl As Control
UseFont = NewFont
PropertyChanged "MyFont"
On Error Resume Next ' For Controls without a Font property
For Each Ctrl In Controls
Ctrl.Font.Name = NewFont
Next
End Property
Public Property Get MyFont() As String
MyFont = UseFont
End Property
Public Property Get MyFontSize() As Long
MyFontSize = UseFontSize
End Property
Private Property Let MyFontSize(NewValue As Long)
Dim Ctrl As Control
UseFontSize = NewValue
PropertyChanged "MyFontSize"
On Error Resume Next ' For Controls without a Font property
For Each Ctrl In Controls
Ctrl.Font.Size = NewValue
Next
End Property
Option Explicit
Private Sub Command1_Click()
CommonDialog1.Flags = cdlCFBoth Or cdlCFFixedPitchOnly
CommonDialog1.FontName = SelectedControls(0).MyFont
CommonDialog1.FontSize = SelectedControls(0).MyFontSize
CommonDialog1.ShowFont
txtMyFont.Text = CommonDialog1.FontName
txtMyFontSize.Text = CommonDialog1.FontSize
End Sub
Private Sub txtMyFont_Change()
Changed = True
End Sub
Private Sub txtMyFontSize_Change()
Changed = True
End Sub
Private Sub PropertyPage_ApplyChanges()
SelectedControls(0).MyFont = txtMyFont.Text
SelectedControls(0).MyFontSize = txtMyFontSize.Text
End Sub
Private Sub PropertyPage_SelectionChanged()
If SelectedControls(0).MyFont = "" Then
txtMyFont.Text = "Courier" ' Default
Else
txtMyFont.Text = SelectedControls(0).MyFont
End If
If SelectedControls(0).MyFontSize > 0 Then
txtMyFontSize.Text = SelectedControls(0).MyFontSize
Else
txtMyFontSize.Text = 8 ' Default
End If
End Sub
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const HWND_TOP = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_HIDEWINDOW = &H80
Private Const WM_CLOSE = &H10
Dim hwndPP As Long
Private Sub PropertyPage_Paint()
Dim lresult As Long
lresult = GetParent(PropertyPage.hwnd) ' Work back to the
hwndPP = GetParent(lresult) ' dialog window.
lresult = SetWindowPos(hwndPP, HWND_TOP, 200&, 200&, &O0, &O0, _
SWP_HIDEWINDOW Or SWP_NOSIZE)
End Sub
Private Sub Timer1_Timer()
Dim lRet As Long
Timer1.Enabled = False ' You will not need the Timer again.
Command1.Value = True ' Click the CommandButton.
PropertyPage_ApplyChanges ' Apply the new settings.
lRet = PostMessage(hwndPP, WM_CLOSE, 0, 0) ' Close the dialog box.
End Sub
Keywords: kbhowto kbapi kbpropsheet kbctrlcreate KB197127