绘制坐标轴的VBA程序，有窗体，实用

songfei

绘制如下图所示的坐标轴

100┫

┃

10 ┫

┗━┳━┳━┳

0 10 20 30

Public Sub xlabel()

'在模型空间中创建文字对象
'坐标轴刻度

Dim insPoint(0 To 2) As Double '声明插入点
Dim textHeight As Double '声明文字高度
Dim textStr As String '声明字符串
Dim textObj As AcadText '声明文字对象

Dim textrot As Single '文字旋转
textrot = Val(UserForm1.TextBox10.text) * 0.017453292

Dim j As Integer

Dim i As Long '点距
i = Val(UserForm1.TextBox3.text)

Dim textlabelend As Long '终点
textlabelend = Val(UserForm1.TextBox2.text)

Dim textlabel As Long '起点
textlabel = Val(UserForm1.TextBox1.text)

Dim xdist As Long
xdist = textlabelend - textlabel

Dim labelnum As Long
labelnum = xdist / i

textHeight = 2 '文字高度设置为 2.0
textStr = Str$(textlabel)

'设置字符串

insPoint(0) = -1 '设置插入点的 x 坐标
insPoint(1) = -6 '设置插入点的 y 坐标
insPoint(2) = 0 '设置插入点的 z 坐标

For j = 0 To labelnum Step 1

'创建 Text 对象
Set textObj = ThisDrawing.ModelSpace.AddText _
(textStr, insPoint, textHeight)

textObj.ObliqueAngle = 0
textObj.Rotation = textrot
textObj.Update

insPoint(0) = insPoint(0) + i
textlabel = textlabel + i
textStr = Str$(textlabel)

Next j

' 在模型空间中添加一条直线作为坐标轴

Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double

' 定义直线的起点
' 和端点
startPoint(0) = 0
startPoint(1) = 0
startPoint(2) = 0
endPoint(0) = xdist
endPoint(1) = 0
endPoint(2) = 0

' 在模型空间中创建直线
Set lineObj = ThisDrawing. _
ModelSpace.AddLine _
(startPoint, endPoint)

' 在模型空间中添加短直线作为刻度线

Dim k As Integer
Dim slineObj As AcadLine
Dim sstartPoint(0 To 2) As Double
Dim sendPoint(0 To 2) As Double

' 定义直线的起点
' 和端点
sstartPoint(0) = 0
sstartPoint(1) = 0
sstartPoint(2) = 0
sendPoint(0) = 0
sendPoint(1) = -4
sendPoint(2) = 0

' 在模型空间中创建短直线

For k = 0 To labelnum Step 1

Set slineObj = ThisDrawing. _
ModelSpace.AddLine _
(sstartPoint, sendPoint)

sstartPoint(0) = sstartPoint(0) + i
sendPoint(0) = sendPoint(0) + i

Next k

End Sub