关于直接用API打印时，设置字体不起反映。请帮忙看一下代码哪有问题（UP有分）

Option Explicit   Private Const LF_FACESIZE = 32   Private Type LOGFONT
      lfHeight As Integer
      lfWidth As Integer
      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 * LF_FACESIZE
   End Type   Private Type DOCINFO
      cbSize As Long
      lpszDocName As String
      lpszOutput As String
      lpszDatatype As String
      fwType As Long
   End Type   Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
   Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
   Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
   Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As Long, ByVal lpInitData As Long) As Long
   Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
   Private 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   ' or Boolean
   Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hdc As Long, lpdi As DOCINFO) As Long
   Private Declare Function EndDoc Lib "gdi32" (ByVal hdc As Long) As Long
   Private Declare Function StartPage Lib "gdi32" (ByVal hdc As Long) As Long
   Private Declare Function EndPage Lib "gdi32" (ByVal hdc As Long) As Long   Const DESIREDFONTSIZE = 12     ' Could use variable, TextBox, etc.   Private Sub Command2_Click()
   ' Print using API calls only
      Dim OutString As String  'String to be rotated
      Dim lf As LOGFONT        'Structure for setting up rotated font
      Dim temp As String       'Temp string var
      Dim result As Long       'Return value for calling API functions
      Dim hOldfont As Long     'Hold old font information
      Dim hPrintDc As Long     'Handle to printer dc
      Dim hFont As Long        'Handle to new Font
      Dim di As DOCINFO        'Structure for Print Document info
      
      Dim hsize As Integer     '字体大小
      Dim vsize As Integer     '放大缩小比例
      Dim Char_Type As String  '打印字体
      
      hsize = 10
      vsize = 1
      Char_Type = "黑体"      OutString = "World你好！"   'Set string to be rotated   ' Set rotation in tenths of a degree, i.e., 1800 = 180 degrees
      
    '  lf.lfEscapement = 1800
    '  lf.lfHeight = (DESIREDFONTSIZE * -20) / Printer.TwipsPerPixelY
    '  hFont = CreateFontIndirect(lf)  'Create the rotated font
      
      '*******************************************************************
      'lfHeight As Integer
      'lfWidth As Integer
      '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 * LF_FACESIZE
      '***************************************
      'int nHeight, // 所创建字体的字符高度
      'int nWidth, // 字体的字符平均宽度
'int nEscapement, // 字符输出方向与水平向右的方向所成角度，'
'以0.1度为单位
'int nOrientation, // 字符与基线的角度，以0.1度为单位
'int nWeight, // 字符颜色的深浅度
'BYTE bItalic, // 斜体属性标志(0:正常字体，非0:斜体)
'BYTE bUnderline, //下划线属性标志(0:无下划线，非0:有下划线)
'BYTE cStrikeOut,//删除线属性标志(0:无删除线，非0:有删除线)
'BYTE nCharSet, //字符集标识0:ANSI字符集，1:系统缺省字符集
'BYTE nOutPrecision, // 输出精度
'BYTE nClipPrecision, // 剪切精度
'BYTE nQuality, // 输出品质
'BYTE nPitchAndFamily, // 字符间距
'LPCTSTR lpszFacename // 现有系统TrueType字体名称''******************************创建字体*************************
     ' lf.lfEscapement = 1800
      lf.lfHeight = CInt(hsize * 22 / 17)
      lf.lfWidth = CInt(hsize * vsize * 2 / 3)
      lf.lfCharSet = 128
      lf.lfFaceName = Trim(Char_Type)
'*******************************创建结束************************            hFont = CreateFontIndirect(lf)
      
      di.cbSize = 20                  ' Size of DOCINFO structure
      di.lpszDocName = "My Document" ' Set name of print job (Optional)   ' Create a printer device context
      hPrintDc = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)      result = StartDoc(hPrintDc, di) 'Start a new print document
      result = StartPage(hPrintDc)    'Start a new page    ' Reset font back to original, non-rotated
      result = SelectObject(hPrintDc, hFont)
   
    ' Send non-rotated text to printer at same page location
      result = TextOut(hPrintDc, 600, 600, OutString, Len_String(OutString))      result = EndPage(hPrintDc)      'End the page
      result = EndDoc(hPrintDc)       'End the print job
      result = DeleteDC(hPrintDc)     'Delete the printer device context
      result = DeleteObject(hFont)    'Delete the font object   End Sub   Private Sub Form_Load()
      Command1.Caption = "API with Printer object"
      Command2.Caption = "Pure API"
   End Sub   Private Function Len_String(ByVal Str As String) As Long   
   '该函数得到该字符串的长度
      Dim I As Long
      Dim Num As Long
      If Str = "" Then
         Len_String = 0
      Else
         Num = 0
         For I = 1 To Len(Str)
            Num = Num + IIf(Asc(Mid(Str, I, 1)) < 0, 2, 1)
         Next
         Len_String = Num
      End If
   End Function'*****************************************************
我采用以上代码用API打印时，发现无法创建字体:当将以上创建字体一段注释掉，打印正常，只不过是系统缺省字体；而加上该段时，想自定义字体时，则发现打印机光走纸，不打印。
请问这是为什么？哪出了问题？

解决方案 »

  1.   

    试试对窗体HDC设置你的字体再TEXTOUT能否成功，CHARSET正确吗？
      

  2.   

    Option ExplicitPrivate Const LF_FACESIZE = 32
    Private 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(LF_FACESIZE) As Byte
    End TypePrivate Type DOCINFO
       cbSize As Long
       lpszDocName As String
       lpszOutput As String
       lpszDatatype As String
       fwType As Long
    End Type
    Private Const LOGPIXELSY = 90Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As Long, ByVal lpInitData As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private 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   ' or Boolean
    Private Declare Function StartDoc Lib "gdi32" Alias "StartDocA" (ByVal hdc As Long, lpdi As DOCINFO) As Long
    Private Declare Function EndDoc Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function StartPage Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function EndPage Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Const DESIREDFONTSIZE = 12     ' Could use variable, TextBox, etc.   Private Sub Command2_Click()
       ' Print using API calls only
          Dim OutString As String  'String to be rotated
          Dim lf As LOGFONT        'Structure for setting up rotated font
          Dim temp As String       'Temp string var
          Dim result As Long       'Return value for calling API functions
          Dim hOldfont As Long     'Hold old font information
          Dim hPrintDc As Long     'Handle to printer dc
          Dim hFont As Long        'Handle to new Font
          Dim di As DOCINFO        'Structure for Print Document info
          
          Dim hsize As Integer     '字体大小
          Dim vsize As Integer     '放大缩小比例
          Dim Char_Type As String  '打印字体
          
          hsize = 10
          vsize = 1
          Char_Type = "黑体"
          OutString = "中国World你好！"   'Set string to be rotated
    '******************************创建字体*************************
          lf.lfEscapement = 3150
          hPrintDc = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)
          '坐标单位要转换一下,否则打出来的文字太小,眼睛看不清楚
          lf.lfHeight = -MulDiv(CInt(hsize * 22 / 17), (GetDeviceCaps(hPrintDc, LOGPIXELSY)), 72)
          lf.lfWidth = -MulDiv(CInt(hsize * vsize * 2 / 3), (GetDeviceCaps(hPrintDc, LOGPIXELSY)), 72)
          'lf.lfCharSet = 128'字符集不要乱设，否则打出来的是乱码
          
          '这里用copymemory更快一些,这里用的是传统的写法
          Dim b() As Byte
          b = StrConv(Char_Type, vbFromUnicode)
          Dim iChar As Long
          For iChar = 0 To UBound(b)
                Debug.Print iChar
                lf.lfFaceName(iChar) = b(iChar)
          Next
    '*******************************创建结束************************      hFont = CreateFontIndirect(lf)
          di.cbSize = 20                  ' Size of DOCINFO structure
          di.lpszDocName = "My Document" ' Set name of print job (Optional)
       ' Create a printer device context
          result = StartDoc(hPrintDc, di) 'Start a new print document
          result = StartPage(hPrintDc)    'Start a new page
        ' Reset font back to original, non-rotated
          result = SelectObject(hPrintDc, hFont)
        ' Send non-rotated text to printer at same page location
          result = TextOut(hPrintDc, 600, 600, OutString, Len_String(OutString))
          result = EndPage(hPrintDc)      'End the page
          result = EndDoc(hPrintDc)       'End the print job
          result = DeleteDC(hPrintDc)     'Delete the printer device context
          result = DeleteObject(hFont)    'Delete the font object
       End Sub   Private Sub Form_Load()
          Command1.Caption = "API with Printer object"
          Command2.Caption = "Pure API"
       End Sub
       
       Private Function Len_String(ByVal Str As String) As Long
          '该函数得到该字符串的长度
          '这个函数可以用api函数lstrlen代替
          Dim s As String
          s = StrConv(Str, vbFromUnicode)
          Len_String = LenB(s)
       End Function
      

  3.   

    主要问题是 LOGFONT结构体声明的有错误当旋转打印时:
     result = TextOut(hPrintDc, 600, 600, OutString, Len_String(OutString))
    这句一定要设置好打印位置,不然很容易打印不全另外,字符集不要乱设
      

  4.   

    现在，字体大小，比例以及旋转都实现了，但是字体设置不起作用，老是宋体，是否 CopyMemory不成功啊？