坐标高程里程点号标记源码

gzxl

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.1 And Abs(pt(1) - bbb) < 0.1 Then dianhao = w1: GoTo 10
11
Next w1
10
pt1 = ThisDrawing.Utility.GetPoint(, "拾取标识点")
Dim ptcen
Dim ptcen1
ptcen = ThisDrawing.Utility.TranslateCoordinates(pt, acWorld, acUCS, False)
Dim x As String '注意一定要是文本类型
Dim y As String '注意一定要是文本类型
Dim h As String '注意一定要是文本类型
zf1 = "X=": zf2 = "Y=": zf3 = "H="
y = zf2 & Format(x1(dianhao), "###0.000") '定义小数点位数
x = zf1 & Format(y1(dianhao), "###0.000") '定义小数点位数
h = zf3 & Format(h1(dianhao), "###0.000") '定义小数点位数
KK = "K" & Format(lc(dianhao), "##0+##0.000")
dianhao1 = dianhao + 1
If dianhao1 <= 9 And dianhao >= 0 Then dh = "QZ00" & dianhao1
If dianhao1 >= 10 And dianhao <= 99 Then dh = "QZ0" & dianhao1
If dianhao1 >= 100 And dianhao <= 999 Then dh = "QZ" & dianhao1
Dim k(0 To 2) As Double
Dim k1(0 To 2) As Double
Dim k6(0 To 2) As Double
Dim k7(0 To 2) As Double
Dim k8(0 To 2) As Double
k(0) = pt1(0)
k(1) = pt1(1) - a - 0.4 * a
k(2) = 0

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 <= dist1 Then dist2 = dist1 Else dist2 = dist
Dim m3, n3 As Variant
txtobj2.GetBoundingBox m3, n3
Dim dist3 As Double
dist3 = n3(0) - m3(0)
If dist2 <= dist3 Then dist4 = dist3 Else dist4 = dist2
Dim k2(0 To 2) As Double
If pt1(0) > 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

gzxl

本人对LISP函数不熟悉，那位高人能将一楼的vba源码转换成LISP源码，发份至gzxl90@126.com,万分感谢！

xiewawa

楼上说的是！谢谢