Liren Large Software Subsidy 10/10.iso/l/l407/4.ddi/FONTDIAL.FR_/FONTDIAL.bin

Visual Basic Form | 1993-04-28 | 5.6 KB | 169 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
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