|
|
Sub bj()
'xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 6)).Merge
'excel.Cells.HorizontalAlignment = excel.xlHAlignCenter
Dim returnObj As Acad3DPolyline
Dim basepnt As Variant
Dim diannum As Double
Dim x1() As Double
Dim y1() As Double
Dim h1() As Double
Dim lc() As Double
On Error Resume Next
' The following example waits for a selection from the user
ThisDrawing.Utility.GetEntity returnObj, basepnt, "选择多段线"
' Create a lightweight Polyline object in model space
n = UBound(returnObj.Coordinates)
diannum = n + 1 / 3
xyz = returnObj.Coordinates
Dim zb(0 To 2) As Double
Dim zb1(0 To 2) As Double
s = 0
p = 0
ReDim x1((n + 1) / 3)
ReDim y1((n + 1) / 3)
ReDim h1((n + 1) / 3)
ReDim lc(n + 1)
For w = 0 To n Step 3
zb(0) = xyz(w)
zb(1) = xyz(w + 1)
zb(2) = xyz(w + 2)
zb1(0) = xyz(w + 3)
zb1(1) = xyz(w + 4)
zb1(2) = xyz(w + 5)
Dim s1 As Double
s1 = Sqr((zb(0) - zb1(0)) ^ 2 + (zb(1) - zb1(1)) ^ 2)
x1(p) = zb(0)
y1(p) = zb(1)
h1(p) = zb(2)
lc(p) = s
s = s + s1
p = p + 1
Next w
ee = x1(0)
Dim a As Double
Dim zf1 As String
Dim zf2 As String
Dim zf3 As String
Dim newlayer As AcadLayer
Set newlayer = ThisDrawing.Layers.Add("C_坐标")
ThisDrawing.ActiveLayer = newlayer
newlayer.Lineweight = acLnWt013
newlayer.Linetype = "Continuous"
a = ThisDrawing.activetextstyle.height
If a = 0 Then
mystring = MsgBox("请输入文本高度,", vbYesNo + vbCritical + vbDefaultButton2, "提示框")
GoTo error
End If
pt = ThisDrawing.Utility.GetPoint(, "拾取注记点")
ee = x1(0)
For w1 = 0 To diannum
aaa = x1(w1)
bbb = y1(w1)
q = x1(1): q1 = x1(2): q2 = x1(3): q3 = x1(4)
If Abs(pt(0) - aaa) = 0 Then dh = "QZ00" & dianhao1
If dianhao1 >= 10 And dianhao = 100 And dianhao
k1(0) = pt1(0)
k1(1) = pt1(1) + 0.4 * a
k1(2) = 0
k6(0) = pt1(0)
k6(1) = pt1(1) + a + 0.8 * a
k6(2) = 0
k7(0) = pt1(0)
k7(1) = pt1(1) + 2 * a + 1.2 * a
k7(2) = 0
k8(0) = pt1(0)
k8(1) = pt1(1) + 3 * a + 1.6 * a
k8(2) = 0
Dim txtobj As AcadText
Dim txtobj1 As AcadText
Dim txtobj2 As AcadText
Dim txtobj3 As AcadText
Dim txtobj4 As AcadText
Set txtobj = ThisDrawing.ModelSpace.AddText(dh, k, a)
Set txtobj1 = ThisDrawing.ModelSpace.AddText(KK, k1, a)
Set txtobj2 = ThisDrawing.ModelSpace.AddText(h, k6, a)
Set txtobj3 = ThisDrawing.ModelSpace.AddText(y, k7, a)
Set txtobj4 = ThisDrawing.ModelSpace.AddText(x, k8, a)
Dim m1, n1 As Variant
txtobj.GetBoundingBox m1, n1
Dim dist As Double
dist = n1(0) - m1(0)
Dim m2, n2 As Variant
txtobj1.GetBoundingBox m2, n2
Dim dist1 As Double
dist1 = n2(0) - m2(0)
If dist pt(0) Then GoTo 50 Else GoTo 60
50
k2(0) = pt1(0) + dist4
k2(1) = pt1(1)
k2(2) = 0
GoTo 100
60
k2(0) = pt1(0) - dist4
k2(1) = pt1(1)
k2(2) = 0
Dim k3(0 To 2) As Double
Dim k4(0 To 2) As Double
Dim k5(0 To 2) As Double
Dim k9(0 To 2) As Double
Dim k10(0 To 2) As Double
k3(0) = k2(0)
k3(1) = k2(1) - a - 0.4 * a
k3(2) = 0
k4(0) = k2(0)
k4(1) = k2(1) + 0.4 * a
k4(2) = 0
k5(0) = k2(0)
k5(1) = k2(1) + a + 0.8 * a
k5(2) = 0
k9(0) = k2(0)
k9(1) = k2(1) + 2 * a + 1.2 * a
k9(2) = 0
k10(0) = k2(0)
k10(1) = k2(1) + 3 * a + 1.6 * a
k10(2) = 0
txtobj.Move k, k3
txtobj1.Move k1, k4
txtobj2.Move k6, k5
txtobj3.Move k7, k9
txtobj4.Move k8, k10
GoTo 100
100
Set pliobj = ThisDrawing.ModelSpace.AddLine(pt, pt1)
Set pliobj = ThisDrawing.ModelSpace.AddLine(pt1, k2)
error:
Exit Sub
End Sub
|
|
置顶卡
