home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
On Hand
/
On_Hand_From_Softbank_1994_Release_2_Disc_2_1994.iso
/
00202
/
s
/
disk1
/
fontdial.fr_
/
fontdial.bin
Wrap
Text File
|
1993-04-28
|
6KB
|
178 lines
VERSION 2.00
Begin Form FontDialog
AutoRedraw = -1 'True
Caption = "Select Font"
ClipControls = 0 'False
ControlBox = 0 'False
Height = 2955
Left = 1140
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2550
ScaleWidth = 4305
Top = 2055
Width = 4425
Begin ListBox lstMatchFonts
Height = 1590
Left = 240
TabIndex = 0
Top = 600
Width = 2415
End
Begin CommandButton cmdOK
Caption = "OK"
Height = 375
Left = 2880
TabIndex = 1
Top = 600
Width = 1215
End
Begin CommandButton cmdCancel
Caption = "Cancel"
Height = 375
Left = 2880
TabIndex = 3
Top = 1200
Width = 1215
End
Begin Label lblFontDemo
Alignment = 2 'Center
AutoSize = -1 'True
BackColor = &H00FFFFFF&
Caption = "Sample"
FontBold = -1 'True
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 12
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H000000C0&
Height = 315
Left = 3000
TabIndex = 4
Top = 1920
Width = 945
End
Begin Label lblFList
AutoSize = -1 'True
Caption = "Available Fonts"
Height = 195
Left = 240
TabIndex = 2
Top = 240
Width = 1320
End
End
Option Explicit
Dim Shared FntNum As Integer
Sub cmdCancel_Click ()
' Hide dialog
FontDialog.Hide
End Sub
Sub cmdOK_Click ()
' Hide dialog
FontDialog.Hide
' Change font for Printer object to selected font.
Printer.FontName = lstMatchFonts.List(FntNum)
' Declare local variable
Dim F
' Apply selected font to all labels
For F = 0 To 6
Card.lblDay(F).FontName = lstMatchFonts.List(FntNum)
Card.lblInTime(F).FontName = lstMatchFonts.List(FntNum)
Card.lblOutTime(F).FontName = lstMatchFonts.List(FntNum)
Card.lblHours(F).FontName = lstMatchFonts.List(FntNum)
Next F
Card.lblTotal.FontName = lstMatchFonts.List(FntNum)
Card.lblRegTotal.FontName = lstMatchFonts.List(FntNum)
Card.lblRegHrs.FontName = lstMatchFonts.List(FntNum)
Card.lblOverTotal.FontName = lstMatchFonts.List(FntNum)
Card.lblOverHrs.FontName = lstMatchFonts.List(FntNum)
End Sub
Sub Form_Load ()
' Position form in middle of screen
FontDialog.Left = (Screen.Width - FontDialog.Width) / 2
FontDialog.Top = (Screen.Height - FontDialog.Height) / 2
' Match available printer fonts to screen fonts and load
' list of matches in list box
GetFonts
End Sub
Sub Form_Resize ()
' As long as the dialog is not minimized.
If FontDialog.WindowState = 0 Then
' Keep the height and width constant while displaying
' a border that looks resizable.
FontDialog.Height = 2970
FontDialog.Width = 4425
End If
End Sub
Sub GetFonts ()
' Declare variable array to store list of matched font names
' from available screen and printer fonts.
Dim BothFonts()
' Declare local variables
Dim PTarget
Dim Match
Dim MatchCnt
Dim PBarW
Dim PBarH
Dim Item
' Initialize MatchCnt
MatchCnt = 0
' Display cancel dialog for font select
CancelFont.Show
' Initialize variable to track height of progress bar in cancel dialog
PBarH = CancelFont.picProgress.ScaleHeight
' For each font in printer font list
For PTarget = 0 To (Printer.FontCount - 1)
' Try to match each font in screen font list
For Match = 0 To (Screen.FontCount - 1)
' Yield processing to detect cmdCancel_Click
DoEvents
' On a match...
If Printer.Fonts(PTarget) = Screen.Fonts(Match) Then
' Increment match counter
MatchCnt = MatchCnt + 1
' Size array to hold matched font names
ReDim Preserve BothFonts(MatchCnt)
' Add font name to matched font list
BothFonts(MatchCnt - 1) = Printer.Fonts(PTarget)
' Exit loop to get next printer font
Match = Screen.FontCount - 1
End If
' Calculate percent progress
PBarW = (Match + 1) * (PTarget + 1)
' Update progress bar
CancelFont.picProgress.Line (0, 0)-(PBarW, PBarH), QBColor(1), BF
' Check next screen font
Next Match
' Try to match next printer font
Next PTarget
' Remove cancel dialog
Unload CancelFont
' Load matched font list in list box
For Item = 0 To MatchCnt - 1
' If list item isn't blank...
If BothFonts(Item) <> "" Then
lstMatchFonts.AddItem BothFonts(Item)
End If
Next Item
End Sub
Sub lstMatchFonts_Click ()
FntNum = lstMatchFonts.ListIndex
lblFontDemo.FontName = lstMatchFonts.List(FntNum)
End Sub
Sub lstMatchFonts_DblClick ()
FntNum = lstMatchFonts.ListIndex
lblFontDemo.FontName = lstMatchFonts.List(FntNum)
End Sub