怎样打印出拉伸或压扁的汉字？

Question

比如以前的户口簿上的户名那样，或者象Word中的字符缩放比例那样，可以在纸上打印出偏长或或扁的汉字来，请问怎么实现，谢谢！

Answer 1

如果对打印质量没有要求，倒有个简单的办法，拿文字当图像处理，比如打印到picturebox里，用paintpicture方法就可以进行缩放了

Answer 2

刚参考一个外文代码写的,大家试试:Private Const LF_FACESIZE = 32
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Const DT_CALCRECT = &H400
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 Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End TypePrivate Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private 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
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Sub printtext(ByVal hdc As Long, ByVal mystr As String, myfont As StdFont, Optional ByVal fontwidth As Integer = 30, Optional ByVal fontheight As Integer = 15, Optional ByVal fontbold As Boolean = False, Optional ByVal fontitlaic As Boolean = False, Optional ByVal fontunderline As Boolean = False, Optional ByVal fontStrikethrough As Boolean = False)Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim tR As RECT
Dim sFont As String
Dim iChar As Integer
Dim temp() As Byte   ' Convert an OLE StdFont to a LOGFONT structure:
   With tLF
     sFont = myfont.Name
     temp = StrConv(sFont, vbFromUnicode)
     For iChar = 1 To Len(sFont)
       .lfFaceName(iChar - 1) = temp(iChar - 1)
     Next iChar
     ' Based on the Win32SDK documentation:
        .lfItalic = myfont.Italic
      lfWeight = IIf(myfont.Bold, FW_BOLD, FW_NORMAL)
      .lfWidth = fontwidth
     .lfHeight = fontheight
     .lfUnderline = fontunderline
     .lfStrikeOut = fontStrikethrough
     .lfCharSet = myfont.Charset
   End With
 
   hFnt = CreateFontIndirect(tLF)  ' Convert the LOGFONT into a font handle   ' Test the font out:
   hFntOld = SelectObject(hdc, hFnt)
   DrawText hdc, mystr, -1, tR, DT_CALCRECT
   OffsetRect tR, 32, 32
   DrawText hdc, mystr, -1, tR, 0&
   SelectObject hdc, hFntOld   '  remember to delete the font when finished
   
   DeleteObject hFntEnd SubPrivate Sub Command1_Click()
Me.Cls
Dim myfont As New StdFont
myfont.Name = "隶书"
printtext Me.hdc, "中华人民共和国", myfontEnd SubPrivate Sub Command2_Click()
Me.Cls
Dim myfont As New StdFont
myfont.Name = "隶书"
printtext Me.hdc, "中华人民共和国", myfont, 10, 80, True, True, True, True
End Sub

Answer 3

输出到打印机:Private Sub Command2_Click()
Dim myfont As New StdFont
myfont.Name = "arial"
printtext Printer.hdc, "中华人民共和国", myfont, 10, 80, True, True, True, True
End Sub

Answer 4

唉，不得不承认楼上的是强悍无比，偶还是投机取巧，弄个简单点的给楼主试试吧：
窗体上放一个PictureBox控件，使用API　TextOut将文字输出到PictureBox上。
大家要问了，那怎么把字拉长和压扁呢？
呵呵，简单啦，使用print.paintpicture方法就可以将图片框里面的东西当做图像拉伸和压扁。并且同时输出到纸上面了。
需要注意的是，PictureBox的大小要调整好，根据你纸张的大小来设置，如果你想输出拉长的字体，就把PictureBox的尺寸设得短一些，输出的时候把它拉长。如果要输出压扁的字体，就先把PictureBox的尺寸设得长一些，输出的时候将它压扁。

Answer 5

to northwolves(狼行天下):
    我正需要这种方法，但有点问题，怎样定位打印的位置，用Printer.CurrentX、Y不起作用，等待中

Answer 6

是VB的StdFont类设计太局限Windows的LOGFONT支持水平宽度设置：LOGFONT.lfWidth

Answer 7

设置打印纸字体，用 PRINTFORM 方法打印应该可以，试试吧（我这里没有打印机）

Answer 8

//怎样定位打印的位置，用Printer.CurrentX、Y不起作用，等待中
printer.CurrentX 应该可以定位，注意，这个位置要根据字体的高度自己计算

Answer 9

to  ljc_zy(彷徨):您试试，可以的话粘贴几行代码给我，我是这样试的不行
Private Sub Command1_Click()
Me.Cls
Dim myfont As New StdFont
myfont.Name = "宋体"
Printer.Print
Printer.CurrentX = 2000
Printer.CurrentY = 1000
'Printer.Print "压扁文字示范："
printtext Printer.hdc, "中华人民共和国", myfont, 10, 40, True
Printer.EndDoc
End SubPrivate Sub Command2_Click()
Me.Cls
Dim myfont As New StdFont
myfont.Name = "隶书"
Me.CurrentX = 2000
Me.CurrentY = 1000
printtext Me.hdc, "中华人民共和国", myfont, 10, 40, True
End Sub

Answer 10

研究了半天，终于解决了，写成了一个重用模块的形式，有兴趣的朋友可以看一下，或者改进一下再贴出来：'本模块用于打印拉长或压扁的文字，例如户口本上的户名，个体营业执照上的文字等。
'PrintText方法在指定的设备场景中输出文字，该设备可以是窗体，图片框或打印机（Printer.hdc）等。
'方法的第一个参数传入一个设备场景句柄。第二、三个参数分别传入文字输出的位置，第四个参数为要输出的文字，第五个参数为字体宽度，参数六为字体高度，后面的参数依次为字体名称、粗体、斜体、下划线、删除线。
'调用如：
'Private Sub Command1_Click() '打印
'  Printer.Print
'  PrintText Printer.hdc, 0, 0, "第一：中华人民共和国", 30, 120, , True
'  PrintText Printer.hdc, 0, 400, "第二：中华人民共和国", 20, 60, , True
'  Printer.EndDoc
'End Sub'Private Sub Command2_Click() '在窗体上预览
'  PrintText Me.hdc, 0,0,"中华人民共和国", 10, 40, "隶书", True
'End Sub
'
'
'
'
'
'
'
Private Const LF_FACESIZE = 32
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Const DT_CALCRECT = &H400
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 Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End TypePrivate Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private 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
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Public Sub PrintText(ByVal hdc As Long, ByVal PrintLeft As Long, ByVal PrintTop As Long, ByVal MyStr As String, Optional ByVal Fontwidth As Integer = 30, Optional ByVal Fontheight As Integer = 15, Optional ByVal FontName As String = "宋体", Optional ByVal Fontbold As Boolean = False, Optional ByVal Fontitalic As Boolean = False, Optional ByVal Fontunderline As Boolean = False, Optional ByVal FontStrikethrough As Boolean = False)  Dim tLF As LOGFONT
  Dim hFnt As Long
  Dim hFntOld As Long
  Dim tR As RECT
  Dim sFont As String
  Dim iChar As Integer
  Dim temp() As Byte
  Dim myfont As New StdFont   With tLF
     sFont = FontName
     temp = StrConv(sFont, vbFromUnicode)
     For iChar = 1 To LenB(sFont)
       .lfFaceName(iChar - 1) = temp(iChar - 1)
     Next iChar
      .lfItalic = Fontitalic
      .lfWeight = IIf(Fontbold, FW_BOLD, FW_NORMAL)
      .lfWidth = Fontwidth
     .lfHeight = Fontheight
     .lfUnderline = Fontunderline
     .lfStrikeOut = FontStrikethrough
     .lfCharSet = myfont.Charset
   End With   hFnt = CreateFontIndirect(tLF)  ' Convert the LOGFONT into a font handle
   
   hFntOld = SelectObject(hdc, hFnt)
   DrawText hdc, MyStr, -1, tR, DT_CALCRECT
   OffsetRect tR, 32, 32
   Dim TempposX As Long
   Dim TempposY As Long
   TempposX = tR.Left
   TempposY = tR.Top
   tR.Left = PrintLeft: tR.Top = PrintTop: tR.Right = tR.Right - TempposX + PrintLeft: tR.Bottom = tR.Bottom - TempposY + PrintTop
   DrawText hdc, MyStr, -1, tR, 0&
   SelectObject hdc, hFntOld
   DeleteObject hFntEnd Sub

Answer 11

tR.Left = 0&: tR.Top = 0&
   DrawText hdc, MyStr, -1, tR, DT_CALCRECT
   OffsetRect tR, PrintLeft, PrintTop  '更简单
   DrawText hdc, MyStr, -1, tR, 0&