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

gzxl 发表于 2010-1-27 11:50:00

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) = 0k1(0) = pt1(0) k1(1) = pt1(1) + 0.4 * a k1(2) = 0k6(0) = pt1(0) k6(1) = pt1(1) + a + 0.8 * a k6(2) = 0k7(0) = pt1(0) k7(1) = pt1(1) + 2 * a + 1.2 * a k7(2) = 0k8(0) = pt1(0) k8(1) = pt1(1) + 3 * a + 1.6 * a k8(2) = 0Dim 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) = 0k4(0) = k2(0) k4(1) = k2(1) + 0.4 * a k4(2) = 0k5(0) = k2(0) k5(1) = k2(1) + a + 0.8 * a k5(2) = 0k9(0) = k2(0) k9(1) = k2(1) + 2 * a + 1.2 * a k9(2) = 0k10(0) = k2(0) k10(1) = k2(1) + 3 * a + 1.6 * a k10(2) = 0txtobj.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 发表于 2010-1-27 11:59:00

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

xiewawa 发表于 2010-1-29 02:27:00

楼上说的是！谢谢

页: [1]

明经CAD社区's Archiver

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