我想楼主的问题是不改变字体宽度而改变高度 不管改变哪个,你可以用api CreateFont来试试,一个例子: Option ExplicitPrivate Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongPrivate Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) 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 LongPrivate Const FW_BOLD = 700 Private Sub ShapePicture() Const TEXT1 = "1234" Const TEXT2 = "rose tulip carnation daffodil peony daisy dandelion snapdragon pansy "Dim new_font As Long Dim old_font As Long Dim hRgn As Long ' Prepare the PictureBox. ScaleMode = vbPixels Picture1.AutoRedraw = True Picture1.ScaleMode = vbPixels Picture1.BorderStyle = vbBSNone Picture1.BackColor = vbBlue Picture1.ForeColor = vbBlack Picture1.DrawWidth = 1 ' Make a big font. new_font = CustomFont(250, 35, 0, 0, _ FW_BOLD, False, False, False, _ "Times New Roman") old_font = SelectObject(Picture1.hdc, new_font) ' Make the region. SelectObject Picture1.hdc, new_font BeginPath Picture1.hdc Picture1.CurrentX = (ScaleWidth - Picture1.TextWidth(TEXT1)) / 2 Picture1.CurrentY = -40 Picture1.Print TEXT1 EndPath Picture1.hdc hRgn = PathToRegion(Picture1.hdc) ' Constrain the PictureBox to the region. SetWindowRgn Picture1.hWnd, hRgn, False ' Restore the original font. SelectObject hdc, old_font ' Free font resources (important!) DeleteObject new_font ' Draw text in the PictureBox. With Picture1.Font .Name = "Times New Roman" .Size = 8 .Bold = False End With Picture1.CurrentY = 0 Do While Picture1.CurrentY <= Picture1.ScaleHeight Picture1.CurrentX = -Picture1.CurrentY Do While Picture1.CurrentX <= Picture1.ScaleWidth Picture1.Print TEXT2; Loop Picture1.CurrentY = Picture1.CurrentY + Picture1.TextHeight(TEXT2) Loop End Sub ' Make a customized font and return its handle. Private Function CustomFont(ByVal hgt As Long, ByVal wid As Long, ByVal escapement As Long, ByVal orientation As Long, ByVal wgt As Long, ByVal is_italic As Long, ByVal is_underscored As Long, ByVal is_striken_out As Long, ByVal face As String) As Long Const CLIP_LH_ANGLES = 16 ' Needed for tilted fonts. CustomFont = CreateFont( _ hgt, wid, escapement, orientation, wgt, _ is_italic, is_underscored, is_striken_out, _ 0, 0, CLIP_LH_ANGLES, 0, 0, face) End Function Private Sub Form_Load() ' Shape the picture. ShapePicture End Sub
不管改变哪个,你可以用api CreateFont来试试,一个例子:
Option ExplicitPrivate Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongPrivate Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) 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 LongPrivate Const FW_BOLD = 700
Private Sub ShapePicture()
Const TEXT1 = "1234"
Const TEXT2 = "rose tulip carnation daffodil peony daisy dandelion snapdragon pansy "Dim new_font As Long
Dim old_font As Long
Dim hRgn As Long ' Prepare the PictureBox.
ScaleMode = vbPixels
Picture1.AutoRedraw = True
Picture1.ScaleMode = vbPixels
Picture1.BorderStyle = vbBSNone
Picture1.BackColor = vbBlue
Picture1.ForeColor = vbBlack
Picture1.DrawWidth = 1 ' Make a big font.
new_font = CustomFont(250, 35, 0, 0, _
FW_BOLD, False, False, False, _
"Times New Roman")
old_font = SelectObject(Picture1.hdc, new_font) ' Make the region.
SelectObject Picture1.hdc, new_font
BeginPath Picture1.hdc
Picture1.CurrentX = (ScaleWidth - Picture1.TextWidth(TEXT1)) / 2
Picture1.CurrentY = -40
Picture1.Print TEXT1
EndPath Picture1.hdc
hRgn = PathToRegion(Picture1.hdc) ' Constrain the PictureBox to the region.
SetWindowRgn Picture1.hWnd, hRgn, False ' Restore the original font.
SelectObject hdc, old_font ' Free font resources (important!)
DeleteObject new_font ' Draw text in the PictureBox.
With Picture1.Font
.Name = "Times New Roman"
.Size = 8
.Bold = False
End With
Picture1.CurrentY = 0
Do While Picture1.CurrentY <= Picture1.ScaleHeight
Picture1.CurrentX = -Picture1.CurrentY
Do While Picture1.CurrentX <= Picture1.ScaleWidth
Picture1.Print TEXT2;
Loop
Picture1.CurrentY = Picture1.CurrentY + Picture1.TextHeight(TEXT2)
Loop
End Sub
' Make a customized font and return its handle.
Private Function CustomFont(ByVal hgt As Long, ByVal wid As Long, ByVal escapement As Long, ByVal orientation As Long, ByVal wgt As Long, ByVal is_italic As Long, ByVal is_underscored As Long, ByVal is_striken_out As Long, ByVal face As String) As Long
Const CLIP_LH_ANGLES = 16 ' Needed for tilted fonts. CustomFont = CreateFont( _
hgt, wid, escapement, orientation, wgt, _
is_italic, is_underscored, is_striken_out, _
0, 0, CLIP_LH_ANGLES, 0, 0, face)
End Function
Private Sub Form_Load()
' Shape the picture.
ShapePicture
End Sub