//巨难问题，低手勿看//

Question

谁看过王国荣VB6 API编程这本书，里面关于设置字体部分有问题请教大侠,很急第十章    FONTDMO.VBP
标准模块：Option ExplicitPublic Const LF_FACESIZE = 32
Public Const DEFAULT_CHARSET = 1
Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        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(0 To LF_FACESIZE - 1) As Byte
End Type
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)‘窗体模块
Option ExplicitPrivate Sub Command1_Click()
    Dim font As LOGFONT
    Dim hOldFont As Long, hFont As Long
     
    RtlMoveMemory font.lfFaceName(0), _
                   ByVal CStr(cmbFontName), _
                   LenB(StrConv(cmbFontName, vbFromUnicode)) + 1
                   
    font.lfHeight = (Val(txtHeight) * -20) / Screen.TwipsPerPixelY
    font.lfWidth = (Val(txtWidth) * -20) / Screen.TwipsPerPixelY
    font.lfEscapement = Val(txtRotate) * 10
    font.lfWeight = IIf(chkBold, 700, 400)
    font.lfItalic = chkItalic
    font.lfUnderline = chkUnderline
    font.lfStrikeOut = chkStrikeThrough
    font.lfCharSet = DEFAULT_CHARSET
     
    hFont = CreateFontIndirect(font)
    hOldFont = SelectObject(Picture1.hDC, hFont)
     
    Picture1.Cls
    Picture1.CurrentX = Picture1.ScaleWidth / 2
    Picture1.CurrentY = Picture1.ScaleHeight / 2
    Picture1.Print txtString.Text
          
    SelectObject Picture1.hDC, hOldFont
    DeleteObject hFont
    
End SubPrivate Sub Form_Load()
    Dim i As Integer
    
    For i = 0 To Screen.FontCount - 1
        cmbFontName.AddItem Screen.Fonts(i)
    Next
    
    cmbFontName.Text = "Times New Roman"
End Sub///////我的问题:要打印出字体怎摸办,把所有的PICTURE1换成PRINTER吗,我试过不行//////

Answer 1

Picture1.Cls
Picture1.CurrentX = Picture1.ScaleWidth / 2
Picture1.CurrentY = Picture1.ScaleHeight / 2
Picture1.Print txtString.Text改成：          printer.font=font
printer.CurrentX = Picture1.ScaleWidth / 2
printer.CurrentY = Picture1.ScaleHeight / 2
printer.Print txtString.Text
printer.enddoc我也是低手，不过最近看过一些关于打印的，不知道这样改可以不？

Answer 2

//////关键在这里
    hFont = CreateFontIndirect(font)
    hOldFont = SelectObject(Picture1.hDC, hFont)
     
    Picture1.Cls
    Picture1.CurrentX = Picture1.ScaleWidth / 2
    Picture1.CurrentY = Picture1.ScaleHeight / 2
    Picture1.Print txtString.Text
          
    SelectObject Picture1.hDC, hOldFont
    DeleteObject hFont

Answer 3

高手一般会近视，你写得太多了看不清！ HEHE

Answer 4

偶没明白~那位"高手"来解释一下?
HELP~~~~

Answer 5

难道就没有人看过王国荣VB6 API编程这本书

Answer 6

难道就没有人看过王国荣VB6 API编程这本书

Answer 7

TO:wsshello(wsshello)这个问题不是没人会答...而是没人敢答啊~!!我看还是重开一贴再问吧!

Answer 8

'标准模块：Option ExplicitPublic Const LF_FACESIZE = 32
Public Const DEFAULT_CHARSET = 1
Public Const DT_SINGLELINE = &H20
Public Const DT_VCENTER = &H4
Public Const DT_CENTER = &H1
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        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(0 To LF_FACESIZE - 1) As Byte
End TypeType RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End TypeDeclare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Declare Sub RtlMoveMemory Lib "kernel32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long'窗体模块Option ExplicitPrivate Sub Command1_Click()
    Picture1.Cls
    DrawString Picture1
End SubPrivate Sub Command2_Click()
    Printer.Print ""
    DrawString Printer
    Printer.EndDoc
End SubPrivate Sub Form_Load()
    Dim i As Integer
    
    For i = 0 To Screen.FontCount - 1
        cmbFontName.AddItem Screen.Fonts(i)
    Next
    
    cmbFontName.Text = "Times New Roman"
End Sub
Private Sub DrawString(objPrinter As Object)
    Dim hOldFont As Long
    Dim hDC As Long
    Dim rc As RECT
    Dim Font As LOGFONT
        
    '// 要使用CreateFont和SelectObject设置字体，必须要将Printer.hDC保存
    '// 到一个变量中再对之操作，这是VB的Bug。
    hDC = objPrinter.hDC
    objPrinter.ScaleMode = 3
    
    rc.Right = objPrinter.ScaleWidth
    rc.Bottom = objPrinter.ScaleHeight
    
    RtlMoveMemory Font.lfFaceName(0), _
                  ByVal CStr(cmbFontName), _
                  LenB(StrConv(cmbFontName, vbFromUnicode)) + 1
    
    '// Printer和PictureBox是不同的,不能简单地乘以-20
    Font.lfHeight = -MulDiv(Val(txtHeight), GetDeviceCaps(hDC, LOGPIXELSY), 72)
    Font.lfWidth = -MulDiv(Val(txtWidth), GetDeviceCaps(hDC, LOGPIXELSX), 72)
    
    Font.lfEscapement = Val(txtRotate) * 10
    Font.lfWeight = IIf(chkBold, 700, 400)
    Font.lfItalic = chkItalic
    Font.lfUnderline = chkUnderline
    Font.lfStrikeOut = chkStrikeThrough
    Font.lfCharSet = DEFAULT_CHARSET
    
    hOldFont = SelectObject(hDC, CreateFontIndirect(Font))
    Call DrawText(hDC, txtString.Text, lstrlen(txtString.Text), rc, DT_SINGLELINE Or DT_CENTER Or DT_VCENTER)
    Call DeleteObject(SelectObject(hDC, hOldFont))
End Sub

Answer 9

偶對api不懂呀，雖然書在偶旁邊，但是偶還是不知道，算了，走人

Answer 10

我试一下junwhj(www.grid2000.com/cn的。