添加第一个类AddText
Public Function AddText(ByVal textString As String, ByVal insertString As Variant, ByVal height As Double) As AcadText
Debug.Assert (VarType(insertPoint) = vbArray + vbDouble)
Debug.Assert (UBound(insertPoint) = 2)
Set AddText = ThisDrawing.ModelSpace.AddText(insertPoint, Width, textString)
End Function
添加第二个类AddMText
Public Function AddMText(ByVal insertPoint As Variant, ByVal Width As Double, ByVal textString As String) As AcadMText
Debug.Assert (VarType(insertPoint) = vbArray + vbDouble)
Debug.Assert (UBound(insertPoint) = 2)
Set AddMText = ThisDrawing.ModelSpace.AddMText(insertPoint, Width, textString)
End Function
添加第三个类AddTextInRectangle
Public Function AddTextInRectangle(ByVal point1 As Variant, ByVal point2 As Variant, ByVal textString As String, Optional ratio As Double = 0.7) As AcadText
Debug.Assert (VarType(point1) = vbArray + vbDouble)
Debug.Assert (UBound(point1) = 2)
Debug.Assert (VarType(point2) = vbArray + vbDouble)
Debug.Assert (UBound(point2) = 2)
'计算矩形的宽、高和中心点
Dim rectHeight As Double, rectWidth As Double, centerPoint As Variant
rectHeight = Abs(point1(1) - point2(1))
rectWidth = Abs(point1(0) - point2(0))
centerPoint = Math.GetMiddlePointBetween2Point(point1, point2)
'创建文字，计算其高宽比
Dim text As AcadText
Set text = AddText(textString, centerPoint, rectHeight)
Dim minPoint As Variant, maxPoint As Variant
text.GetBoundingBox minPoint, maxPoint
Dim textHeight As Double, TextWidth As Double
textHeight = Abs(minPoint(1) - maxPoint(1))
TextWidth = Abs(minPoint(0) - maxPoint(0))
'根据矩形的宽、高和文字的容纳比例确定文字的高或宽
Dim heightRatio As Double
heightRatio = textHeight / TextWidth
If (heightRatio > rectHeight / rectWidth) Then
textHeight = rectHeight * ratio
Else
TextWidth = rectWidth * ratio
textHeight = TextWidth * heightRatio
End If
'缩放和移动文字
text.Alignment = acAlignmentBottomCenter
text.AlignmentPoint = centerPoint
text.height = textHeight
Set AddTextInRectangle = text
End Function
主函数程序：
Public Sub CreateText()
Dim point1(0 To 2) As Double, point2(0 To 2) As Double
SetPoint3d point1, 0, 0, 0
SetPoint3d point2, 20, 5, 0
Dim mSpace As New clsModelSpace
mSpace.AddTextInRectangle point1, point2, "cadhelp"
mSpace.AddRectangle point1, point2
array在vb什么意思啊End Sub

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。