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