整理资料，发现了N年前自己用VB编的一个控件试验品，献丑了！

博英纳言

这个控件试验大概是2001年左右编的，在VB6和Windows98和windows2k中试验通过，贴在这里吧，看看有没有用啦！

说明：在VB6中新建一个工程，新建一个ActiveX控件文件，放一个Picture，命名为Picture1。放一个text，名称为Text2；再放一个RichTextBox，名称为RichTextBox1。把text和RichTextBox的visible属性都设置为False。然后再建一个模块，把下面的代码复制到模块里。

'******下面是模块级的声明******'
Public Const DEFULT_CHARSET = 1

'用指定的属性建立逻辑字体
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

'选入设备环境
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

'删除设备环境
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'文本输出函数
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

'测量文本字符串
Public Declare Function GetTextExtentPoint32& Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE)

'定义LOGFONT结构
Public Type LOGFONT
    lfHeight As Long                      '字体高度。
    lfWidth As Long                       '字体宽度，通常设置为0。
    lfEscapement As Long                  '文本字符串的旋转角度。
    lfOrientation As Long                 '每个字符串的旋转角度，似乎不起作用。
    lfWeight As Long                      '字体的粗细。
    lfItalic As Byte                      '斜体字。
    lfUnderline As Byte                   '是否加下划线。
    lfStrikeOut As Byte                   '是否加删除线。
    lfCharSet As Byte                     '字符集。
    lfOutprecision As Byte                '指定输出精度。
    lfClipPrecision As Byte               '指定裁剪精度。
    lfQuality As Byte                     '指定输出质量。
    lfPitchAndFamily As Byte              '字体是否等宽和选择字体家族。
    lfFaceName As String * 20             '字体名称。
End Type

'****** 定义SIZE结构 ******
Public Type SIZE
    cx As Long
    cy As Long
End Type

再把下面的代码复制到控件里，就可以试验了：

Option Explicit
   
    Dim Xdw As Integer

Private Sub Picture1_KeyPress(KeyAscii As Integer)
    Dim keycode As String
    Dim shurustr As String
    Dim zhstr As String
    Dim s As SIZE
    Dim zikuan As Integer
   
        keycode = KeyAscii
        shurustr = Chr(keycode)
   
        Text2.Text = Text2.Text + shurustr
        zhstr = Text2.Text
        
        GetTextExtentPoint32 Picture1.hdc, zhstr, Len(zhstr), s
        zikuan = CLng(Val(s.cx))
        
        If zikuan >= Picture1.ScaleHeight Or keycode = 13 Then
            RichTextBox1.Text = RichTextBox1.Text + zhstr + Chr(13)
            Text2.Text = ""
            Xdw = Xdw + 27
        ElseIf zikuan <= Picture1.ScaleHeight Then
            shuchu Picture1.hdc, zhstr, Xdw, 0
        End If
        
End Sub

Private Sub UserControl_Initialize()
    Picture1.ScaleMode = 3
    xianshidingwei
End Sub

Private Sub shuchu(hdc As Long, strout As String, x As Integer, y As Integer)
    Dim myfont As LOGFONT
    Dim hFont As Long
    Dim hOldFont As Long
    Dim zh As Integer
        zh = Picture1.FontSize
        myfont.lfHeight = 28  '(zh * -20) / Screen.TwipsPerPixelY  决定字体显示的大小
        myfont.lfEscapement = 2700
        myfont.lfFaceName = "monnet" & Chr(0)  '"monnet"是字体名称，这里用的是蒙古文记事本的字体。蒙古文记事本由蒙古文化网站的傲日格乐老师编制。
        hFont = CreateFontIndirect(myfont)
        hOldFont = SelectObject(Picture1.hdc, hFont)
        TextOut hdc, x, y, strout, Len(strout)
        SelectObject Picture1.hdc, hOldFont
        DeleteObject hFont
End Sub
Private Sub xianshidingwei()
    Dim hangshu As Integer
        hangshu = Picture1.ScaleWidth / 48
        Xdw = Picture1.ScaleWidth / hangshu / 2
End Sub


你可以在这个基础上修改，直到你认为满意为止。我就是通过做这个试验，编制了网络控件的。咱们的论坛不开放贴图，就不上图了！
有什么问题，咱们再联系：）、

[ 本帖最后由 博英纳言 于 2007-5-29 15:11 编辑 ]