home *** CD-ROM | disk | FTP | other *** search
/ Dan Appleman's Visual Bas…s Guide to the Win32 API / Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD / VB5PG32.mdf / vbpg32 / samples5 / ch11 / fontview.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-02-16  |  10.7 KB  |  326 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    Caption         =   "Font Viewer"
  4.    ClientHeight    =   4020
  5.    ClientLeft      =   3735
  6.    ClientTop       =   1650
  7.    ClientWidth     =   7365
  8.    BeginProperty Font 
  9.       Name            =   "MS Sans Serif"
  10.       Size            =   8.25
  11.       Charset         =   0
  12.       Weight          =   700
  13.       Underline       =   0   'False
  14.       Italic          =   0   'False
  15.       Strikethrough   =   0   'False
  16.    EndProperty
  17.    ForeColor       =   &H80000008&
  18.    LinkMode        =   1  'Source
  19.    LinkTopic       =   "Form1"
  20.    PaletteMode     =   1  'UseZOrder
  21.    ScaleHeight     =   4020
  22.    ScaleWidth      =   7365
  23.    Begin VB.CommandButton cmdFontInfo 
  24.       Caption         =   "Show Info"
  25.       Height          =   435
  26.       Left            =   2700
  27.       TabIndex        =   17
  28.       Top             =   3300
  29.       Width           =   1335
  30.    End
  31.    Begin VB.TextBox TxtWeight 
  32.       Height          =   315
  33.       Left            =   1260
  34.       TabIndex        =   8
  35.       Text            =   "400"
  36.       Top             =   2880
  37.       Width           =   1335
  38.    End
  39.    Begin VB.CommandButton CmdShowMetrics 
  40.       Appearance      =   0  'Flat
  41.       BackColor       =   &H80000005&
  42.       Caption         =   "ShowMetrics"
  43.       Height          =   495
  44.       Left            =   2700
  45.       TabIndex        =   16
  46.       Top             =   2700
  47.       Width           =   1335
  48.    End
  49.    Begin VB.TextBox TxtEscapement 
  50.       Height          =   315
  51.       Left            =   1260
  52.       TabIndex        =   6
  53.       Text            =   "0"
  54.       Top             =   2520
  55.       Width           =   1335
  56.    End
  57.    Begin VB.CommandButton CmdShowFont 
  58.       Appearance      =   0  'Flat
  59.       BackColor       =   &H80000005&
  60.       Caption         =   "ShowFont"
  61.       Default         =   -1  'True
  62.       Height          =   495
  63.       Left            =   2700
  64.       TabIndex        =   13
  65.       Top             =   2100
  66.       Width           =   1335
  67.    End
  68.    Begin VB.TextBox TxtWidth 
  69.       Height          =   315
  70.       Left            =   1260
  71.       TabIndex        =   4
  72.       Text            =   "10"
  73.       Top             =   2160
  74.       Width           =   1335
  75.    End
  76.    Begin VB.PictureBox PicText 
  77.       Height          =   1635
  78.       Left            =   4200
  79.       ScaleHeight     =   1605
  80.       ScaleWidth      =   2925
  81.       TabIndex        =   9
  82.       Top             =   2100
  83.       Width           =   2955
  84.    End
  85.    Begin VB.TextBox TxtHeight 
  86.       Height          =   315
  87.       Left            =   1260
  88.       TabIndex        =   1
  89.       Text            =   "10"
  90.       Top             =   1800
  91.       Width           =   1335
  92.    End
  93.    Begin VB.TextBox TxtSample 
  94.       Height          =   315
  95.       Left            =   5400
  96.       TabIndex        =   14
  97.       Text            =   "ABC"
  98.       Top             =   1440
  99.       Width           =   1755
  100.    End
  101.    Begin VB.CheckBox ChkStrikeout 
  102.       Caption         =   "StrikeOut"
  103.       Height          =   375
  104.       Left            =   4140
  105.       TabIndex        =   12
  106.       Top             =   1020
  107.       Width           =   1575
  108.    End
  109.    Begin VB.CheckBox ChkItalic 
  110.       Caption         =   "Italic"
  111.       Height          =   375
  112.       Left            =   4140
  113.       TabIndex        =   11
  114.       Top             =   600
  115.       Width           =   1575
  116.    End
  117.    Begin VB.CheckBox ChkUnderline 
  118.       Caption         =   "Underline"
  119.       Height          =   315
  120.       Left            =   4140
  121.       TabIndex        =   10
  122.       Top             =   240
  123.       Width           =   1635
  124.    End
  125.    Begin VB.ListBox FontList 
  126.       Height          =   1395
  127.       Left            =   240
  128.       Sorted          =   -1  'True
  129.       TabIndex        =   0
  130.       Top             =   240
  131.       Width           =   3015
  132.    End
  133.    Begin VB.Label Label4 
  134.       Alignment       =   1  'Right Justify
  135.       Appearance      =   0  'Flat
  136.       BackColor       =   &H80000005&
  137.       BackStyle       =   0  'Transparent
  138.       Caption         =   "Weight"
  139.       ForeColor       =   &H80000008&
  140.       Height          =   315
  141.       Left            =   120
  142.       TabIndex        =   7
  143.       Top             =   2940
  144.       Width           =   1035
  145.    End
  146.    Begin VB.Label Label3 
  147.       Alignment       =   1  'Right Justify
  148.       Appearance      =   0  'Flat
  149.       BackColor       =   &H80000005&
  150.       BackStyle       =   0  'Transparent
  151.       Caption         =   "Escapement"
  152.       ForeColor       =   &H80000008&
  153.       Height          =   315
  154.       Left            =   60
  155.       TabIndex        =   5
  156.       Top             =   2580
  157.       Width           =   1155
  158.    End
  159.    Begin VB.Label Label2 
  160.       Alignment       =   1  'Right Justify
  161.       Appearance      =   0  'Flat
  162.       BackColor       =   &H80000005&
  163.       BackStyle       =   0  'Transparent
  164.       Caption         =   "Width"
  165.       ForeColor       =   &H80000008&
  166.       Height          =   255
  167.       Left            =   540
  168.       TabIndex        =   3
  169.       Top             =   2220
  170.       Width           =   675
  171.    End
  172.    Begin VB.Label Label1 
  173.       Alignment       =   1  'Right Justify
  174.       Appearance      =   0  'Flat
  175.       BackColor       =   &H80000005&
  176.       BackStyle       =   0  'Transparent
  177.       Caption         =   "Height"
  178.       ForeColor       =   &H80000008&
  179.       Height          =   255
  180.       Left            =   540
  181.       TabIndex        =   2
  182.       Top             =   1860
  183.       Width           =   675
  184.    End
  185.    Begin VB.Label Label5 
  186.       Appearance      =   0  'Flat
  187.       BackColor       =   &H80000005&
  188.       BackStyle       =   0  'Transparent
  189.       Caption         =   "Sample Text"
  190.       ForeColor       =   &H80000008&
  191.       Height          =   255
  192.       Left            =   4200
  193.       TabIndex        =   15
  194.       Top             =   1500
  195.       Width           =   1095
  196.    End
  197. Attribute VB_Name = "Form1"
  198. Attribute VB_GlobalNameSpace = False
  199. Attribute VB_Creatable = False
  200. Attribute VB_PredeclaredId = True
  201. Attribute VB_Exposed = False
  202. Option Explicit
  203. ' Copyright 
  204.  1997 by Desaware Inc. All Rights Reserved.
  205. Private Sub cmdFontInfo_Click()
  206.     If FontToUse = 0 Then
  207.         MsgBox "Select a font"
  208.         Exit Sub
  209.     End If
  210.     frmInfo.Show 1
  211. End Sub
  212. ' Creates a logical font based on the various control
  213. ' settings. Then displays a sample string in that font.
  214. Private Sub CmdShowFont_Click()
  215.     Dim lf As LOGFONT
  216.     #If Win32 Then
  217.     Dim oldhdc&
  218.     #Else
  219.     Dim oldhdc%
  220.     #End If
  221.     Dim TempByteArray() As Byte
  222.     Dim dl&, x%
  223.     Dim ByteArrayLimit&
  224.     Dim rc As RECT
  225.     PicText.Cls
  226.     If FontToUse <> 0 Then dl = DeleteObject(FontToUse)
  227.     lf.lfHeight = Val(TxtHeight.Text)
  228.     lf.lfWidth = Val(TxtWidth.Text)
  229.     lf.lfEscapement = Val(TxtEscapement.Text)
  230.     lf.lfWeight = Val(TxtWeight.Text)
  231.     If (ChkItalic.value = 1) Then lf.lfItalic = 1
  232.     If (ChkUnderline.value = 1) Then lf.lfUnderline = 1
  233.     If (ChkStrikeout.value = 1) Then lf.lfStrikeOut = 1
  234.     lf.lfOutPrecision = OUT_DEFAULT_PRECIS
  235.     lf.lfClipPrecision = OUT_DEFAULT_PRECIS
  236.     ' This kind of chr$ assignment is no longer necessary and
  237.     ' is not advisiable
  238.     ' lf.lfQuality = Chr$(DEFAULT_QUALITY)
  239.     lf.lfQuality = DEFAULT_QUALITY
  240.     lf.lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
  241.     lf.lfCharSet = DEFAULT_CHARSET
  242.     ' When we changed this to a byte array, we
  243.     ' no longer can assign a text string to a fixed
  244.     ' length byte array.
  245.     ' lf.lfFaceName = FontList.Text & Chr$(0)
  246.     #If Win32 Then
  247.         TempByteArray = StrConv(FontList.Text & Chr$(0), vbFromUnicode)
  248.     #Else
  249.         TempByteArray = FontList.Text & Chr$(0)
  250.     #End If
  251.     ByteArrayLimit = UBound(TempByteArray)
  252.     For x% = 0 To ByteArrayLimit
  253.         lf.lfFaceName(x%) = TempByteArray(x%)
  254.     Next x%
  255.     FontToUse = CreateFontIndirect(lf)
  256.     If FontToUse = 0 Then Exit Sub
  257.     oldhdc = SelectObject(PicText.hdc, FontToUse)
  258.     ' Get the client rectangle in order to place the
  259.     ' text midway down the box
  260.     dl& = GetClientRect(PicText.hwnd, rc)
  261.     dl& = TextOut(PicText.hdc, 1, rc.Bottom / 2, (TxtSample.Text), Len(TxtSample.Text))
  262.     dl& = SelectObject(PicText.hdc, oldhdc)
  263. End Sub
  264. ' Display the text metrics for the physical font.
  265. Private Sub CmdShowMetrics_Click()
  266.     Dim tm As TEXTMETRIC
  267.     Dim r$
  268.     Dim crlf$
  269.     #If Win32 Then
  270.     Dim oldfont&
  271.     #Else
  272.     Dim oldfont%
  273.     #End If
  274.     Dim di&
  275.     Dim tbuf As String * 80
  276.     crlf$ = Chr$(13) + Chr$(10)
  277.     If FontToUse = 0 Then
  278.         MsgBox "Font not yet selected"
  279.         Exit Sub
  280.     End If
  281.     oldfont = SelectObject(PicText.hdc, FontToUse)
  282.     di = GetTextMetrics(PicText.hdc, tm)
  283.     di = GetTextFace(PicText.hdc, 79, tbuf)
  284.     ' Add to r$ only the part up to the null terminator
  285.     r$ = "Facename = " + agGetStringFromLPSTR$(tbuf) + crlf$
  286.     ' No need to have Asc conversions here
  287.     If (tm.tmPitchAndFamily And TMPF_TRUETYPE) <> 0 Then r$ = r$ + "... is a TrueType font" + crlf$
  288.     If (tm.tmPitchAndFamily And TMPF_DEVICE) <> 0 Then r$ = r$ + "... is a Device font" + crlf$
  289.     ' Curiously enough, this bit is set for variable width fonts.
  290.     If (tm.tmPitchAndFamily And TMPF_FIXED_PITCH) <> 0 Then
  291.         r$ = r$ + "... is a variable pitch font" + crlf$
  292.     Else
  293.         r$ = r$ + "... is a fixed pitch font" + crlf$
  294.     End If
  295.     If (tm.tmPitchAndFamily And TMPF_VECTOR) <> 0 Then r$ = r$ + "... is a vector font" + crlf$
  296.     r$ = r$ + "Height=" + Str$(tm.tmHeight) + ", Ascent=" + Str$(tm.tmAscent) + ", Descent=" + Str$(tm.tmDescent) + crlf$
  297.     r$ = r$ + "Internal Leading=" + Str$(tm.tmInternalLeading) + ", External Leading=" + Str$(tm.tmExternalLeading) + crlf$
  298.     r$ = r$ + "Average char width=" + Str$(tm.tmAveCharWidth) + ", Max char width=" + Str$(tm.tmMaxCharWidth) + crlf$
  299.     r$ = r$ + "Weight=" + Str$(tm.tmWeight) + ", First char=" + Str$(Asc(tm.tmFirstChar)) + ", Last char=" + Str$(Asc(tm.tmLastChar)) + crlf$
  300.     MsgBox r$, 0, "Physical Font Metrics"
  301.     di = SelectObject(PicText.hdc, oldfont)
  302. End Sub
  303. Private Sub FontList_Click()
  304.     CmdShowFont_Click
  305. End Sub
  306. '   Load the font list dialog box with the available fonts
  307. Private Sub Form_Load()
  308.     Dim x%
  309.     Dim a$
  310.     #If Win16 Then
  311.         ' This functionality is disabled for Win16
  312.         cmdFontInfo.Visible = False
  313.     #End If
  314.     Screen.MousePointer = 11
  315.     For x% = 1 To Screen.FontCount
  316.         a$ = Screen.Fonts(x%)
  317.         If a$ <> "" Then FontList.AddItem a$
  318.     Next x%
  319.     Screen.MousePointer = 0
  320. End Sub
  321. Private Sub Form_Unload(Cancel As Integer)
  322.     ' Be sure to clean up GDI objects when leaving the program
  323.     Dim di&
  324.     If FontToUse& <> 0 Then di = DeleteObject(FontToUse)
  325. End Sub
  326.