frmfont.frm

国防工业部VB高级编程源码

Private Sub chkItalic_Click()
'斜体
ViewFont
End Sub

Private Sub chkStrikeOut_Click()
'删除线
    ViewFont
End Sub

Private Sub chkUnderline_Click()
'下划线
    ViewFont
End Sub

Private Sub cmbFam_Click()
'字族
    ViewFont
End Sub

Private Sub CmbFontF_Click()
'字样
    ViewFont
End Sub


Private Sub cmbPitch_click()
'间距
ViewFont
End Sub

Private Sub cmbQuality_click()
'输出质量
ViewFont
End Sub

Private Sub CmbSet_Click()
'字符集
ViewFont
End Sub

Private Sub cmdClose_Click()
'结束程序
End
End Sub

Private Sub cmdInfo_Click()
'显示物理字体信息
frmInfo.Show
End Sub

Private Sub cmdOK_Click()
'显示逻辑字体
ViewFont
End Sub

Private Sub cmdR_Click()
'恢复旋转角度为0
    LnEscapement.X2 = rctEscapement.Right - 150
    LnEscapement.Y2 = LnEscapement.Y1
    m_intR = LnEscapement.X2 - LnEscapement.X1
    m_dblEscapement = 0
    ViewFont
End Sub

Private Sub Form_Load()
    Dim i As Integer
    Dim varFont
    '得到系统的字样
    For i = 1 To Screen.FontCount
        varFont = Screen.Fonts(i)
        If varFont <> "" Then
            CmbFontF.AddItem varFont
        End If
    Next
    '设置初始值
    CmbFontF.ListIndex = 1
    For i = 0 To CmbFontF.ListCount - 1
        If CmbFontF.List(i) = "宋体" Then
            CmbFontF.ListIndex = i
        End If
    Next
    '字符集
    CmbSet.AddItem "ANSI字符集"
    CmbSet.AddItem "系统缺省字符集"
    CmbSet.AddItem "OEM字符集"
    CmbSet.AddItem "SHIFTJIS字符集"
    CmbSet.AddItem "符号字符集"
    CmbSet.ListIndex = 1
    '字形
    cmbFam.AddItem "Decorative"
    cmbFam.AddItem "Dontcare"
    cmbFam.AddItem "Modern"
    cmbFam.AddItem "Roman"
    cmbFam.AddItem "Script"
    cmbFam.AddItem "Swiss"
    cmbFam.ListIndex = 1
    '输出质量
    cmbQuality.AddItem "Default"
    cmbQuality.AddItem "Draft"
    cmbQuality.AddItem "Proof"
    cmbQuality.ListIndex = 0
    '间距
    cmbPitch.AddItem "Default"
    cmbPitch.AddItem "Fixed"
    cmbPitch.AddItem "Variable"
    cmbPitch.ListIndex = 0
    
    
    '得到系统物理字体结构
    GetTextMetrics PicFont.hdc, tmFont
    '填写字体高度和宽度缺省值
    txtHeight = CStr(tmFont.tmHeight)
    txtWidth = CStr(tmFont.tmAveCharWidth)
    
    '设置调节旋转角度的图形
    rctEscapement.Left = shpEscapement.Left
    rctEscapement.Top = shpEscapement.Top
    rctEscapement.Right = shpEscapement.Left + shpEscapement.Width
    rctEscapement.Bottom = shpEscapement.Top + shpEscapement.Height
    
    LnEscapement.X1 = (rctEscapement.Left + rctEscapement.Right) / 2
    LnEscapement.Y1 = (rctEscapement.Top + rctEscapement.Bottom) / 2
    LnEscapement.X2 = rctEscapement.Right - 250
    LnEscapement.Y2 = LnEscapement.Y1
    m_intR = LnEscapement.X2 - LnEscapement.X1
    m_dblEscapement = 0
    
End Sub

Sub ViewFont()
    '在图片框中显示字体
    '字体的句柄
    Dim lFontHandle As Long
    '原来的DC句柄
    Dim lDcOld As Long
    '字符数组
    Dim bytArray() As Byte
    '数组上限
    Dim intArrayCount As Integer
    
    '显示文本
    Dim strShow As String
    
    Dim i As Integer
    
    '从文本框中得到文本，否则使用缺省的文本
    If Len(txtShow.Text) = 0 Then
        strShow = m_strDefault
    Else
        strShow = txtShow.Text
    End If
    strShow = strShow
    
    'lfFont.lfFaceName = CmbFontF.Text + Chr(0) 错误
    
    '把字符从Unicode转为系统缺省码页
    bytArray = StrConv(CmbFontF.Text + Chr(0), vbFromUnicode)
    '得数组上限
    intArrayCount = UBound(bytArray)
    '给lfFontName赋值
    For i = 0 To intArrayCount
        lfFont.lfFaceName(1 + i) = bytArray(i)
    Next
    
    '设置lfFont的属性
    lfFont.lfHeight = udHeight.Value
    lfFont.lfWidth = udWidth.Value
    lfFont.lfWeight = sldrFont.Value * 100
 
    lfFont.lfUnderline = chkUnderline.Value
    lfFont.lfStrikeOut = chkStrikeOut.Value
    lfFont.lfItalic = chkItalic.Value
    lfFont.lfEscapement = m_dblEscapement
    lfFont.lfOrientation = lfFont.lfEscapement
    
    Select Case cmbFam.ListIndex
    Case 0
        lfFont.lfPitchAndFamily = FF_DECORATIVE
    Case 1
        lfFont.lfPitchAndFamily = FF_DONTCARE
    Case 2
        lfFont.lfPitchAndFamily = FF_MODERN
    Case 3
        lfFont.lfPitchAndFamily = FF_ROMAN
    Case 4
        lfFont.lfPitchAndFamily = FF_SCRIPT
    Case 5
        lfFont.lfPitchAndFamily = FF_SWISS
    End Select
    
    Select Case cmbPitch.ListIndex
    Case 0
        lfFont.lfPitchAndFamily = lfFont.lfPitchAndFamily Or DEFAULT_PITCH
    Case 1
        lfFont.lfPitchAndFamily = lfFont.lfPitchAndFamily Or FIXED_PITCH
    Case 2
        lfFont.lfPitchAndFamily = lfFont.lfPitchAndFamily Or VARIABLE_PITCH
    End Select
    
    Select Case cmbQuality.ListIndex
    Case 0
        lfFont.lfQuality = DEFAULT_QUALITY
    Case 1
        lfFont.lfQuality = DRAFT_QUALITY
    Case 2
        lfFont.lfQuality = PROOF_QUALITY
    End Select
    
    Select Case CmbSet.ListIndex
    Case 0
        lfFont.lfCharSet = ANSI_CHARSET
    Case 1
        lfFont.lfCharSet = DEFAULT_CHARSET
    Case 2
        lfFont.lfCharSet = OEM_CHARSET
    Case 3
        lfFont.lfCharSet = SHIFTJIS_CHARSET
    Case 4
        lfFont.lfCharSet = SYMBOL_CHARSET
    End Select
    
    '设置字体颜色
    PicFont.ForeColor = lblColor.BackColor
    '创建逻辑字体
    lFontHandle = CreateFontIndirect(lfFont)
    
    '清除图片框上的文本
    PicFont.Cls
    '从新绘制文本
    If lFontHandle <> 0 Then
    '把逻辑字体赋值给DC
        lDcOld = SelectObject(PicFont.hdc, lFontHandle)
        TextOut PicFont.hdc, 50, 60, strShow, lstrlen(strShow)
        '注意，这里不能用len()
        
        '得到物理字体的信息
        GetTextMetrics PicFont.hdc, tmFont
        '得到物理字体的字样信息
        GetTextFace PicFont.hdc, 79, g_strFontName
    '恢复原来的字体
        SelectObject PicFont.hdc, lDcOld
    End If
    '删除句柄
    DeleteObject lDcOld
      
End Sub



Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    '调用
    Form_MouseMove Button, Shift, X, Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    '角度大小
    Dim dblTan As Double
    '鼠标位置和圆点的差
    Dim dblx As Double
    Dim dbly As Double
    '鼠标点击在圆上，并拖动
    If X >= shpEscapement.Left And X <= shpEscapement.Left + shpEscapement.Width _
        And Y >= shpEscapement.Top And Y <= shpEscapement.Top + shpEscapement.Height Then
        '是左键
        If Button = 1 Then
                       '旋转
        dblx = X - LnEscapement.X1
        dbly = Y - LnEscapement.Y1
        
        '如果是90度或者270度
        If dblx = 0 Then
            LnEscapement.X2 = LnEscapement.X1
            If dbly > 0 Then
                LnEscapement.Y2 = LnEscapement.Y1 + m_intR
                m_dblEscapement = 90
            Else
                LnEscapement.Y2 = LnEscapement.Y1 - m_intR
                m_dblEscapement = 270
            End If
            
        Else
        '计算角度
            dblTan = Atn(dbly / dblx)
            '在各个域里面计算Line的位置
            If dblx > 0 Then
                LnEscapement.X2 = LnEscapement.X1 + m_intR * Cos(dblTan)
                LnEscapement.Y2 = LnEscapement.Y1 + m_intR * Sin(dblTan)
            Else
                LnEscapement.X2 = LnEscapement.X1 - m_intR * Cos(dblTan)
                LnEscapement.Y2 = LnEscapement.Y1 - m_intR * Sin(dblTan)
            End If
         '计算角度大小
            m_dblEscapement = dblTan / 3.1415926 * 180
             If dblx > 0 Then
                If dbly < 0 Then
                    m_dblEscapement = m_dblEscapement + 360
                End If
            Else
                    m_dblEscapement = m_dblEscapement + 180
            End If
        End If
        '显示字体
        ViewFont
        End If
End If
End Sub

Private Sub lblColor_Click()
    '“颜色”对话框弹出，选择颜色
    cmdlgColor.ShowColor
    lblColor.BackColor = cmdlgColor.Color
    lblCaption.ForeColor = lblColor.BackColor
    '显示字体
    ViewFont
End Sub

Private Sub sldrFont_Scroll()
'粗细
    ViewFont
End Sub

Private Sub txtHeight_Change()
    '在文本框中输入字体高度
    If IsNumeric(txtHeight.Text) Then
        If Int(txtHeight.Text) <= 100 And Int(txtHeight.Text) >= 1 Then
            udHeight.Value = Int(txtHeight.Text)
        End If
    End If
End Sub

Private Sub txtWidth_Change()
'在文本框中输入字体宽度
    If IsNumeric(txtWidth.Text) Then
        If Int(txtWidth.Text) <= 100 And Int(txtWidth.Text) >= 1 Then
            udWidth.Value = Int(txtWidth.Text)
        End If
    End If
End Sub

Private Sub udHeight_Change()
'高度
    ViewFont
End Sub

Private Sub udWidth_Change()
'宽度
    ViewFont
End Sub