GFSelectFont/GFSelectFont.frm
VERSION 5.00
Begin VB.Form GFSelectFontfrm
BorderStyle = 1 'Fest Einfach
Caption = "Select Font"
ClientHeight = 4050
ClientLeft = 45
ClientTop = 330
ClientWidth = 6030
Enabled = 0 'False
Icon = "GFSelectFont.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4050
ScaleWidth = 6030
StartUpPosition = 3 'Windows‑Standard
Visible = 0 'False
Begin VB.TextBox GFSFFontExampleText
Height = 285
Left = 4620
MaxLength = 32
TabIndex = 6
Text = "abc ABC xyz 123"
Top = 1860
Width = 1155
End
Begin VB.Frame GFSFFrame1
Caption = "Effects:"
Height = 1575
Left = 120
TabIndex = 15
Top = 2280
Width = 2175
Begin VB.CheckBox GFSFFontStrikeThroughCheck
Caption = "Strike through"
Height = 195
Left = 180
TabIndex = 8
Top = 720
Width = 1815
End
Begin VB.CheckBox GFSFFontUnderlineCheck
Caption = "Underline"
Height = 195
Left = 180
TabIndex = 7
Top = 360
Width = 1875
End
End
Begin VB.Frame GFSFFrame2
Caption = "Example:"
Height = 1575
Left = 2400
TabIndex = 14
Top = 2280
Width = 3375
Begin VB.PictureBox GFSFFontExamplePicture
AutoRedraw = ‑1 'True
BorderStyle = 0 'Kein
Height = 1155
Left = 120
ScaleHeight = 1155
ScaleWidth = 3135
TabIndex = 16
Top = 300
Width = 3135
End
End
Begin VB.TextBox GFSFFontNameText
Height = 285
Left = 120
MaxLength = 1024
TabIndex = 0
Top = 420
Width = 2175
End
Begin VB.TextBox GFSFFontStyleText
Height = 285
Left = 2400
MaxLength = 128
TabIndex = 2
Top = 420
Width = 1395
End
Begin VB.ListBox GFSFFontStyleList
Height = 1230
Left = 2400
TabIndex = 3
Top = 720
Width = 1395
End
Begin VB.CommandButton GFSFCancelCommand
Cancel = ‑1 'True
Caption = "Cancel"
Height = 315
Left = 4620
TabIndex = 10
Top = 840
Width = 1155
End
Begin VB.CommandButton GFSFOkCommand
Caption = "Ok"
Default = ‑1 'True
Height = 315
Left = 4620
TabIndex = 9
Top = 420
Width = 1155
End
Begin VB.ListBox GFSFFontNameList
Height = 1230
Left = 120
Sorted = ‑1 'True
TabIndex = 1
Top = 720
Width = 2175
End
Begin VB.ListBox GFSFFontSizeList
Height = 1230
Left = 3900
TabIndex = 5
Top = 720
Width = 615
End
Begin VB.TextBox GFSFFontSizeText
Height = 285
Left = 3900
MaxLength = 4
TabIndex = 4
Top = 420
Width = 615
End
Begin VB.Label GFSFLabel3
Caption = "Size:"
Height = 195
Left = 3900
TabIndex = 13
Top = 180
Width = 615
End
Begin VB.Label GFSFLabel2
Caption = "Font Style:"
Height = 195
Left = 2400
TabIndex = 12
Top = 180
Width = 1395
End
Begin VB.Label GFSFLabel1
Caption = "Font Name:"
Height = 255
Left = 120
TabIndex = 11
Top = 180
Width = 2175
End
End
Attribute VB_Name = "GFSelectFontfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
'
'This form allows the user to choose a font installed on the local machine.
'Alternatively we could use ChooseFont, but this dialog looks nicer.
'
'NOTE: you should never replace the picture box GFSFFontExamplePicture
'by a label as a label would display the example text in multiline‑style.
'NOTE: the maximum length of text box texts has been limited at design time
'(important to avoid overflow of font size).
'
'THIS FORM IS PLUG‑IN CODE, DO NOT CHANGE!
'
'GFSelectFont_SelectFont
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'other
Dim GFSFContinueFlag As Boolean
Dim GFSFCancelFlag As Boolean
Dim GFSelectFont_SelectFontCalledFlag As Boolean
'************************************INTERFACE SUBS*************************************
Public Function GFSelectFont_SelectFont(ByRef FontName As String, ByRef FontSize As Single, ByRef FontBoldFlag As Boolean, ByRef FontItalicFlag As Boolean, ByRef FontUnderlineFlag As Boolean, ByRef FontStrikeThroughFlag As Boolean) As Boolean
'On Error Resume Next 'returns True if 'Ok' was pressed, False if user pressed 'Cancel'
Dim Temp As Long
'verify
If GFSelectFont_SelectFontCalledFlag = True Then
GoTo Error:
Else
GFSelectFont_SelectFontCalledFlag = True
End If
'preset
Call GFSFFontNameList_ReloadSub(FontName)
Call GFSFFontStyleList_ReloadSub(FontItalicFlag, FontBoldFlag)
Call GFSFFontSizeList_ReloadSub(FontSize)
'
If FontUnderlineFlag = True Then
GFSFFontUnderlineCheck.Value = 1
Else
GFSFFontUnderlineCheck.Value = 0
End If
If FontStrikeThroughFlag = True Then
GFSFFontStrikeThroughCheck.Value = 1
Else
GFSFFontStrikeThroughCheck.Value = 0
End If
'reset
GFSFContinueFlag = False 'reset
GFSFCancelFlag = False 'reset
'open window
GFSelectFontfrm.Enabled = True
GFSelectFontfrm.Visible = True
GFSelectFontfrm.Refresh
'
Do While (GFSFContinueFlag = False) And (GFSFCancelFlag = False)
Call Sleep(10) 'decreases CPU usage (use before using DoEvents to redraw windows correctly), use 10 instead of the default value 100 to avoid cursor jerking
DoEvents
Loop
'
If (GFSFContinueFlag = True) Then
FontName = GFSFFontNameText.Text
If ISFONTAVAILABLE(FontName) = False Then FontName = "Arial" 'verify (important, if garbage was entered in text box)
FontSize = Val(GFSFFontSizeText.Text)
If FontSize < 2 Then FontSize = 2 'verify (important, if garbage was entered in text box)
If FontSize > 128 Then FontSize = 128 'verify (important, if garbage was entered in text box)
FontBoldFlag = Not (InStr(1, GFSFFontStyleText.Text, "BOLD", vbTextCompare) = 0)
FontItalicFlag = Not (InStr(1, GFSFFontStyleText.Text, "ITALIC", vbTextCompare) = 0)
FontUnderlineFlag = CHECKTOBOOL(GFSFFontUnderlineCheck.Value)
FontStrikeThroughFlag = CHECKTOBOOL(GFSFFontStrikeThroughCheck.Value)
GFSelectFont_SelectFont = True 'user pressed 'Ok'
End If
If (GFSFCancelFlag = True) Then
FontName = ""
FontSize = 0
FontBoldFlag = False
FontItalicFlag = False
FontUnderlineFlag = False
FontStrikeThroughFlag = False
GFSelectFont_SelectFont = False 'user pressed 'Cancel'
End If
'hide window
GFSelectFont_SelectFontCalledFlag = False 'reset
GFSelectFontfrm.Visible = False
GFSelectFontfrm.Enabled = False
GFSelectFontfrm.Refresh
Exit Function
Error:
FontName = "" 'reset (error)
FontSize = 0 'reset (error)
FontBoldFlag = False 'reset (error)
FontItalicFlag = False 'reset (error)
FontUnderlineFlag = False 'reset (error)
FontStrikeThroughFlag = False 'reset (error)
GFSelectFont_SelectFont = False 'reset (error)
Exit Function
End Function
Public Function GFSelectFont_GetDefaultFontName() As String
'On Error Resume Next 'returns a font name that can be used in any case
'
'NOTE: use this function if e.g. the font name entered by user is invalid.
'
GFSelectFont_GetDefaultFontName = "ARIAL"
End Function
'*********************************END OF INTERFACE SUBS*********************************
'************************************CONTROL EVENTS*************************************
Private Sub GFSFFontNameText_Change()
'On Error Resume Next
Dim ListLoop As Integer
'begin
For ListLoop = 1 To GFSFFontNameList.ListCount
If UCase$(GFSFFontNameList.List(ListLoop ‑ 1)) = UCase$(Trim$(GFSFFontNameText.Text)) Then
If Not (GFSFFontNameList.ListIndex = (ListLoop ‑ 1)) Then 'verify (avoid endless loop)
GFSFFontNameList.ListIndex = (ListLoop ‑ 1)
End If
Call GFSFFontExamplePicture_Update
Exit For
End If
Next ListLoop
End Sub
Private Sub GFSFFontStyleText_Change()
'On Error Resume Next
Dim ListLoop As Integer
'begin
For ListLoop = 1 To GFSFFontStyleList.ListCount
If UCase$(GFSFFontStyleList.List(ListLoop ‑ 1)) = UCase$(Trim$(GFSFFontStyleText.Text)) Then
If Not (GFSFFontStyleList.ListIndex = (ListLoop ‑ 1)) Then 'verify (avoid endless loop)
GFSFFontStyleList.ListIndex = (ListLoop ‑ 1)
End If
Call GFSFFontExamplePicture_Update
Exit For
End If
Next ListLoop
End Sub
Private Sub GFSFFontSizeText_Change()
'On Error Resume Next
Dim ListLoop As Integer
'begin
For ListLoop = 1 To GFSFFontSizeList.ListCount
If UCase$(GFSFFontSizeList.List(ListLoop ‑ 1)) = UCase$(Trim$(GFSFFontSizeText.Text)) Then
If Not (GFSFFontSizeList.ListIndex = (ListLoop ‑ 1)) Then 'verify (avoid endless loop)
GFSFFontSizeList.ListIndex = (ListLoop ‑ 1)
End If
Call GFSFFontExamplePicture_Update
Exit For
End If
Next ListLoop
End Sub
Private Sub GFSFFontUnderlineCheck_Click()
'On Error Resume Next
Call GFSFFontExamplePicture_Update
End Sub
Private Sub GFSFFontStrikeThroughCheck_Click()
'On Error Resume Next
Call GFSFFontExamplePicture_Update
End Sub
Private Sub GFSFFontExampleText_Change()
'On Error Resume Next
Call GFSFFontExamplePicture_Update
End Sub
Private Sub GFSFOkCommand_Click()
'On Error Resume Next
GFSFContinueFlag = True
End Sub
Private Sub GFSFCancelCommand_Click()
'On Error Resume Next
GFSFCancelFlag = True
End Sub
Private Sub GFSFFontNameList_Click()
'On Error Resume Next
If Not (GFSFFontNameList.ListIndex = True) Then 'verify
GFSFFontNameText.Text = GFSFFontNameList.List(GFSFFontNameList.ListIndex)
End If
End Sub
Private Sub GFSFFontStyleList_Click()
'On Error Resume Next
If Not (GFSFFontStyleList.ListIndex = True) Then 'verify
GFSFFontStyleText.Text = GFSFFontStyleList.List(GFSFFontStyleList.ListIndex)
End If
End Sub
Private Sub GFSFFontSizeList_Click()
'On Error Resume Next
If Not (GFSFFontSizeList.ListIndex = True) Then 'verify
GFSFFontSizeText.Text = GFSFFontSizeList.List(GFSFFontSizeList.ListIndex)
End If
End Sub
'*********************************END OF CONTROL EVENTS*********************************
'******************************RELOAD AND UPDATE FUNCTIONS******************************
Private Sub GFSFFontNameList_ReloadSub(ByVal FontNameDefault As String)
'On Error Resume Next 'selects FontNameDefault if in list
Dim Temp As Long
GFSFFontNameList.Clear 'reset
'GFSFFontNameList.Sorted = True 'property write protected
'verify
If FontNameDefault = "" Then 'verify
FontNameDefault = GFSelectFont_GetDefaultFontName 'default
End If
'begin
For Temp = 1 To Screen.FontCount
GFSFFontNameList.AddItem Screen.Fonts(Temp ‑ 1)
Next Temp
For Temp = 1 To GFSFFontNameList.ListCount
If UCase$(GFSFFontNameList.List(Temp ‑ 1)) = UCase$(FontNameDefault) Then
GFSFFontNameList.ListIndex = Temp ‑ 1
Exit For
End If
Next Temp
End Sub
Private Sub GFSFFontStyleList_ReloadSub(ByVal FontItalicFlag As Boolean, ByVal FontBoldFlag As Boolean)
'On Error Resume Next
GFSFFontStyleList.Clear 'reset
GFSFFontStyleList.AddItem "Standard"
GFSFFontStyleList.AddItem "Bold"
GFSFFontStyleList.AddItem "Italic"
GFSFFontStyleList.AddItem "Bold‑Italic"
'preset
If (FontItalicFlag = True) And (FontBoldFlag = True) Then
GFSFFontStyleList.ListIndex = 3
End If
If (FontItalicFlag = True) And (FontBoldFlag = False) Then
GFSFFontStyleList.ListIndex = 2
End If
If (FontItalicFlag = False) And (FontBoldFlag = True) Then
GFSFFontStyleList.ListIndex = 1
End If
If (FontItalicFlag = False) And (FontBoldFlag = False) Then
GFSFFontStyleList.ListIndex = 0
End If
GFSFFontStyleList.Text = GFSFFontStyleList.List(GFSFFontStyleList.ListIndex)
End Sub
Private Sub GFSFFontSizeList_ReloadSub(ByVal FontSize As Single)
'On Error Resume Next
Dim Temp As Long
GFSFFontSizeList.Clear 'reset
For Temp = 8 To 72 Step 2
GFSFFontSizeList.AddItem LTrim$(Str$(Temp))
Next Temp
'preset
If FontSize = 0 Then 'verify
FontSize = 8 'default
End If
'begin
For Temp = 1 To GFSFFontSizeList.ListCount
If GFSFFontSizeList.List(Temp ‑ 1) = LTrim$(Str$(FontSize)) Then
GFSFFontSizeList.ListIndex = Temp ‑ 1
Exit For
End If
Next Temp
GFSFFontSizeText.Text = LTrim$(Str$(FontSize))
End Sub
Private Sub GFSFFontExamplePicture_Update()
'On Error Resume Next
Call GFSFFontExamplePicture_UpdateSub(GFSFFontNameText.Text, Val(GFSFFontSizeText.Text), _
Not (InStr(1, GFSFFontStyleText.Text, "BOLD", vbTextCompare) = 0), _
Not (InStr(1, GFSFFontStyleText.Text, "ITALIC", vbTextCompare) = 0), _
CHECKTOBOOL(GFSFFontUnderlineCheck.Value), CHECKTOBOOL(GFSFFontStrikeThroughCheck.Value), _
GFSFFontExampleText.Text)
End Sub
Private Sub GFSFFontExamplePicture_UpdateSub(ByVal FontName As String, ByVal FontSize As Single, ByVal FontBoldFlag As Boolean, ByVal FontItalicFlag As Boolean, ByVal FontUnderlineFlag As Boolean, ByVal FontStrikeoutFlag As Boolean, ByVal ExampleText As String)
On Error GoTo Error: 'important
'verify
If FontName = "" Then FontName = "Arial" 'just to make sure
If FontSize < 1 Then FontSize = 1 'the system will pass 0 as FontSize when initializing this form
'hide picture box
GFSFFontExamplePicture.Visible = False
GFSFFontExamplePicture.Refresh
'transfer properties
GFSFFontExamplePicture.Font.Name = FontName
GFSFFontExamplePicture.Font.Size = FontSize
GFSFFontExamplePicture.Font.Bold = FontBoldFlag
GFSFFontExamplePicture.Font.Italic = FontItalicFlag
GFSFFontExamplePicture.Font.Underline = FontUnderlineFlag
GFSFFontExamplePicture.Font.Strikethrough = FontStrikeoutFlag
'print text
GFSFFontExamplePicture.Cls 'reset
GFSFFontExamplePicture.CurrentX = (GFSFFontExamplePicture.ScaleWidth / 2) ‑ (GFSFFontExamplePicture.TextWidth(ExampleText) / 2)
GFSFFontExamplePicture.CurrentY = (GFSFFontExamplePicture.ScaleHeight / 2) ‑ (GFSFFontExamplePicture.TextHeight(ExampleText) / 2)
GFSFFontExamplePicture.Print ExampleText
'display picture box
GFSFFontExamplePicture.Visible = True
GFSFFontExamplePicture.Refresh
Exit Sub
Error:
GFSFFontExamplePicture.Visible = False 'hide (error)
Exit Sub
End Sub
'**************************END OF RELOAD AND UPDATE FUNCTIONS***************************
'***********************************GENERAL FUNCTIONS***********************************
Private Function ISFONTAVAILABLE(ByVal FontName As String) As Boolean 'small help function
'On Error Resume Next 'returns True if font is installed on local machine, False if not
Dim FontLoop As Integer
For FontLoop = 1 To Screen.FontCount
If UCase$(Screen.Fonts(FontLoop)) = UCase$(FontName) Then
ISFONTAVAILABLE = True
Exit Function
End If
Next FontLoop
ISFONTAVAILABLE = False
Exit Function
End Function
Private Function CHECKTOBOOL(ByVal CheckBoxValue As Integer) As Boolean
'On Error Resume Next
If CheckBoxValue = 1 Then
CHECKTOBOOL = True
Else
CHECKTOBOOL = False
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
'On Error Resume Next
GFSFCancelFlag = True
'Cancel = True 'no, modal loop is to be left and form unloaded
End Sub
[END OF FILE]