第十章 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吗,我试过不行//////
标准模块: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吗,我试过不行//////
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货