怎样让文字的宽度和图像框的宽度一样
本帖最后由 ndsc213456789 于 2012-04-18 16:39:06 编辑 我在一个名为p1的Picturebox中显示字符串，想让这个字符串宽度和Picturebox宽度一样：程序如下：
sub showTXT(str as string)
dim fs,tw
fs = P1.Font.Size: tw = P1.TextWidth(str) '记录下原有字体size以及在这个size下显示文字的宽度
If tw <> P1.ScaleWidth Then
P1.Font.Size = fs * P1.ScaleWidth / tw '根据Picturebox宽度重新设定字号
end if
p1.print str
end sub
'增加一个 PictureBox : p0
Option Explicit
Sub showTxt(str As String)
Dim tw As Single
Dim th As Single
Dim r As Single
p0.Font = p1.Font
p0.Cls
p0.Print str
tw = p0.TextWidth(str)
th = p0.TextHeight(str)
r = p1.ScaleWidth / tw
p1.PaintPicture p0.Image, 0, 0, tw * r, th * r, 0, 0, tw, th
End Sub
Private Sub Command1_Click()
showTxt "hello"
End Sub
Private Sub Form_Load()
p0.Visible = False
p0.Move p1.Left, p1.Top, p1.Width, p1.Height
p0.AutoRedraw = True
End Sub
'1、在网上下载一个GDIPlus.tlb，下载地址：http://www.vbgood.com/thread-82786-1-1.html
'2、使用Gdiplus.tlb，将其放到system32中，然后添加对其的引用
'3、手动设置Form的AutoRedraw＝True，ScaleMode=Pixels
Option Explicit
Dim lngGraphics As Long
Dim gpP As GpStatus
Dim lngPen1 As Long
Dim lngToken As Long
Dim lngSolidBrush As Long
Dim GpInput As GdiplusStartupInput
Private lngFontFamily As Long '字体类型
Private lngStringFormat As Long '字符串格式
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'设置字体大小为图片框的显示宽度：Picture1.ScaleHeight
'设置显示的区域高度为：Picture1.ScaleHeight
'设置显示的区域高度为：Picture1.ScaleWidth
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Private Sub Command1_Click()
Dim intP As Integer
Dim bolP As Boolean
gpP = GdipCreateFromHDC(Picture1.hDC, lngGraphics)
bolP = DrawNormalText("新宋体", _
&H808000FF, _
StringAlignmentCenter, _
Picture1.ScaleHeight, _
FontStyle.FontStyleBold, _
UnitPixel, _
TextRenderingHintAntiAliasGridFit, _
0, _
0, _
Picture1.ScaleWidth, _
Picture1.ScaleHeight, _
"中")
Picture1.Refresh
End Sub
Private Sub Form_Load()
Dim bolP As Boolean
With Me
.Caption = "GDIPlus范例"
.Width = 960 * 15
.Height = 720 * 15
.Left = (Screen.Width - .Width) * 0.5
.Top = (Screen.Height - .Height) * 0.5
End With
'以下两个属性最好手动设置
Picture1.AutoRedraw = True
Picture1.ScaleMode = 3
Picture1.Width = Picture1.Height '使图片框的长宽一致
GpInput.GdiplusVersion = 1
If lngToken = 0 Then bolP = (GdiplusStartup(lngToken, GpInput) = Ok)
End Sub
'************************************************************************************************************************
'函数功能：按照一定的格式书写文字，正常排列（不包括：旋转、描边等）
'参数说明：strFontName：字体名称
' ：lngFontColor：文字颜色
' ：stringAlignMode：对齐方式
' ：sngFontSize：字体大小
' ：lngFontStyle：字体样式（粗体、斜体..）
' ：DrawUnit：绘图单元
' ：TextRenderMode：文本渲染模式
' ：lngLeft：绘制文本区域 Left
' ：lngTop：绘制文本区域 Top
' ：lngWidth：绘制文本区域 Width
' ：lngHeight：绘制文本区域 Height
' ：strText：要书写的文本
'返回说明：成功：True 失败：False
'************************************************************************************************************************
Private Function DrawNormalText(ByVal strFontName As String, ByVal lngFontColor As Long, _
ByVal StringAlignMode As StringAlignment, _
ByVal sngFontSize As Single, ByVal lngFontStyle As Long, _
ByVal DrawUnit As GpUnit, ByVal TextRenderMode As TextRenderingHint, _
ByVal lngLeft As Long, ByVal lngTop As Long, _
ByVal lngWidth As Long, ByVal lngHeight As Long, ByVal strText As String) As Boolean
Dim gpP As GpStatus
Dim lngCurFont As Long
Dim rclayout As RECTF
On Error GoTo errFun
gpP = GdipCreateFontFamilyFromName(strFontName, 0, lngFontFamily)
gpP = GdipCreateStringFormat(0, 0, lngStringFormat)
gpP = GdipCreateSolidFill(lngFontColor, lngSolidBrush)
gpP = GdipSetStringFormatAlign(lngStringFormat, StringAlignMode)
gpP = GdipCreateFont(lngFontFamily, sngFontSize, lngFontStyle, DrawUnit, lngCurFont)
gpP = GdipSetTextRenderingHint(lngGraphics, TextRenderMode)
With rclayout
.Left = lngLeft
.Top = lngTop
.Width = lngWidth
.Height = lngHeight
End With
gpP = GdipDrawString(lngGraphics, strText, -1, lngCurFont, rclayout, lngStringFormat, lngSolidBrush)
gpP = GdipDeleteFontFamily(lngFontFamily)
gpP = GdipDeleteStringFormat(lngStringFormat)
gpP = GdipDeleteFont(lngCurFont)
gpP = GdipDeleteBrush(lngSolidBrush)
lngSolidBrush = 0
lngFontFamily = 0
If IsNull(gpP) Then
DrawNormalText = False
Else
DrawNormalText = True
End If
Exit Function
errFun:
DrawNormalText = False
End Function
'************************************************************************************************************************
'函数功能：按照一定的格式书写文字，特殊格式包括：旋转、描边等
'参数说明：strFontName：字体名称
' ：lngBrushColor：文字颜色
' ：stringAlignMode：对齐方式
' ：lngFontStyle：字体样式（粗体、斜体..）
' ：lngLineColor：边框颜色
' ：sngLineWidth：边框宽度
' ：DrawLineUnit：边框绘制单位
' ：sngFontSize：字体大小
' ：lngLeft：绘制文本区域 Left
' ：lngTop：绘制文本区域 Top
' ：lngWidth：绘制文本区域 Width
' ：lngHeight：绘制文本区域 Height
' ：strText：要书写的文本
' ：dblAngle：字符串和X轴正方向的夹角（0～2*Pi）
'返回说明：成功：True 失败：False
'************************************************************************************************************************
Private Function DrawSpecialText(ByVal strFontName As String, ByVal lngBrushColor As Long, _
ByVal StringAlignMode As StringAlignment, ByVal lngFontStyle As Long, _
ByVal lngLineColor As Long, ByVal sngLineWidth As Single, _
ByVal DrawLineUnit As GpUnit, ByVal BrushMode As FillMode, _
ByVal sngFontSize As Single, ByVal lngLeft As Long, _
ByVal lngTop As Long, ByVal lngWidth As Long, _
ByVal lngHeight As Long, ByVal strText As String, _
ByVal dblAngle As Double) As Boolean
Dim gpP As GpStatus
Dim lngStringPath As Long
Dim rclayout As RECTL
On Error GoTo errFun
gpP = GdipCreateFontFamilyFromName(strFontName, 0, lngFontFamily) '创建字体类型
gpP = GdipCreateStringFormat(0, 0, lngStringFormat) '创建字符串格式
gpP = GdipSetStringFormatAlign(lngStringFormat, StringAlignMode) '设置字符串格式
gpP = GdipCreateSolidFill(lngBrushColor, lngSolidBrush) '创建一个实心刷子
gpP = GdipCreatePen1(lngLineColor, sngLineWidth, DrawLineUnit, lngPen1)
With rclayout
.Left = lngLeft
.Top = lngTop
.Width = lngWidth
.Height = lngHeight
End With
gpP = GdipCreatePath(BrushMode, lngStringPath)
gpP = GdipAddPathStringI(lngStringPath, strText, -1, lngFontFamily, _
lngFontStyle, sngFontSize, rclayout, lngStringFormat)
gpP = GdipFillPath(lngGraphics, lngSolidBrush, lngStringPath)
gpP = GdipDrawPath(lngGraphics, lngPen1, lngStringPath)
If IsNull(gpP) Then
DrawSpecialText = False
Else
DrawSpecialText = True
End If
gpP = GdipDeleteFontFamily(lngFontFamily)
gpP = GdipDeleteStringFormat(lngStringFormat)
gpP = GdipDeletePath(lngStringPath)
gpP = GdipDeleteBrush(lngSolidBrush)
gpP = GdipDeletePen(lngPen1)
lngSolidBrush = 0
lngFontFamily = 0
lngPen1 = 0
Exit Function
errFun:
DrawSpecialText = False
End Function
Sub showTxt(str As String)
Dim tw As Single
Dim th As Single
Dim r As Single
p0.Font = p1.Font
'先将放大字体到稍小与宽度
p0.FontSize = 10
r = p1.ScaleWidth / p0.TextWidth(str)
p0.FontSize = Int(10 * r)
Debug.Print p0.FontSize
p0.Cls
p0.Print str
tw = p0.TextWidth(str)
th = p0.TextHeight(str)
r = p1.ScaleWidth / tw
p1.PaintPicture p0.Image, 0, 0, tw * r, th * r, 0, 0, tw, th
End Sub
