[求助]

wangyancai 发表于 2005-6-5 22:34:00

Sub addline1() Dim lineobj As AcadLine Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double pt1(0) = 1000: pt1(1) = 1000: pt1(2) = 0 pt2(0) = 1200: pt1(1) = 1000: pt1(2) = 0 Set lineobj = ThisDrawing.ModelSpace.AddLine(pt1, pt2) End Sub Sub rotateline() Dim lineobj As AcadLine Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double pt1(0) = 1000: pt1(1) = 1000: pt1(2) = 0 pt2(0) = 1200: pt1(1) = 1000: pt1(2) = 0 Set lineobj = ThisDrawing.ModelSpace.AddLine(pt1, pt2) ZoomAll Dim basepoint(0 To 2) As Double Dim rotationangle As Double dim angle as double basepoint(0) = pt1(0): basepoint(1) = pt1(1): basepoint(2) = pt1(2) rotationangle = ThisDrawing.Utility.GetAngle(, "指定角度") Angle = Angle *3.1415926/180 tbangle = Round(angle, 2) rotationangle=tbangle linobj.Rotate basepoint, rotationangle lineobj.Update End Sub

wyj7485 发表于 2005-6-6 12:02:00

'Angle = Angle *3.1415926/180 'tbangle = Round(angle, 2) 'rotationangle=tbangle'上面3句不要啊! 'linobj.Rotate basepoint, rotationangle'此句linobj与前不一致啊!应该为lineobj

wangyancai 发表于 2005-6-6 19:11:00

此程序运行不出来急盼高手指点，要不然毕不了业了，救命呀

Public Function getpoint(pt As Variant, x As Double, y As Double) As Variant Dim pttarget(0 To 2) As Double pttarget(0) = pt(0) + x: pttarget(1) = pt(1) + y: pttarget(2) = 0 getpoint = pttarget Public Sub Testline() Dim d1, d3, R1 As Double Dim p1 As Variant Dim p2, p3, p4, p5 As Variant Dim ln1, ln2, ln3, ln4 As AcadLine d1 = 15 R1 = 9 d3 = 4.1 p1(0) = 100: p1(1) = 100: p1(2) = 0 p2 = getpoint(p1, 0, d1 / 2) p3 = getpoint(p1, 0, R1 - 0.5 - d3 / 2) p4 = getpoint(p3, 0.5, 0.5) p5 = getpoint(pt4, 0, d3) Set ln1 = ThisDrawing.ModelSpace.addline(p1, p2) Set ln2 = ThisDrawing.ModelSpace.addline(p2, p3) Set ln3 = ThisDrawing.ModelSpace.addline(p3, p4) Set ln4 = ThisDrawing.ModelSpace.addline(p4, p5) End Sub

雪山飞狐_lzh 发表于 2005-6-6 20:27:00

Dim ln1, ln2, ln3, ln4 As AcadLine

VB里没有这种写法，如果这么写表示ln1, ln2, ln3是变体，ln4 是AcadLine

Public Sub Testline() Dim d1 As Double, d3 As Double, R1 As Double Dim p1(2) As Double Dim p2, p3, p4, p5 Dim ln1 As AcadLine, ln2 As AcadLine, ln3 As AcadLine, ln4 As AcadLine d1 = 15 R1 = 9 d3 = 4.1 p1(0) = 100: p1(1) = 100: p1(2) = 0 p2 = getpoint(p1, 0#, d1 / 2) p3 = getpoint(p1, 0#, R1 - 0.5 - d3 / 2) p4 = getpoint(p3, 0.5, 0.5) p5 = getpoint(p4, 0#, d3) Set ln1 = ThisDrawing.ModelSpace.AddLine(p1, p2) Set ln2 = ThisDrawing.ModelSpace.AddLine(p2, p3) Set ln3 = ThisDrawing.ModelSpace.AddLine(p3, p4) Set ln4 = ThisDrawing.ModelSpace.AddLine(p4, p5) End Sub

wangyancai 发表于 2005-6-8 16:19:00

[VBA]谢谢你，有了你的帮忙程序终于运行出来了，可以再帮一下吗，再行行好吧ok？

Sub offsetline() Dim lineobj As AcadLine Dim p1(0 To 2) As Double Dim p2(0 To 2) As Double p1(0) = 50: p1(1) = 50: p1(2) = 0 p2(0) = 60: p2(1) = 60: p2(2) = 0 Set lineobj = ThisDrawing.ModelSpace.AddLine(p1, p2) lineobj.Closed = True ZoomAll Dim offsetobj As Variant offsetobj = lineobj1.Offset(0.25) End Sub

zyh0312 发表于 2005-6-8 20:20:00

Sub offsetline() Dim lineobj As AcadLine Dim p1(0 To 2) As Double Dim p2(0 To 2) As Double p1(0) = 50: p1(1) = 50: p1(2) = 0 p2(0) = 60: p2(1) = 60: p2(2) = 0 Set lineobj = ThisDrawing.ModelSpace.AddLine(p1, p2) '去除该行lineobj.Closed = True ZoomAll Dim offsetobj As Variant offsetobj = lineobj.Offset(0.25) '该处原来为offsetobj 1= lineobj.Offset(0.25) End Sub

wangyancai 发表于 2005-6-8 23:39:00

两条直线怎么延伸到相交，不相交怎么办帮修改一下程序

Sub lengthenline() Dim lineobj As AcadLine Dim p1(0 To 2) As Double Dim p2(0 To 2) As Double p1(0) = 50: p1(1) = 50: p1(2) = 0 p2(0) = 60: p2(1) = 60: p2(2) = 0 setlineobj1 = ThisDrawing.ModelSpace.AddLine(p1, p2) lineobj1.Update Dim p3(0 To 2) As Double Dim p4(0 To 2) As Double p3(0) = 40: p3(1) = 80: p3(2) = 0 p4(0) = 100: p4(1) = 80: p4(2) = 0 Set lineobj2 = ThisDrawing.ModelSpace.AddLine(p3, p4) lineobj1.EndPoint = lineobj2 lineobj1.Update End Sub

wangyancai 发表于 2005-6-8 23:41:00

[VBA]再帮一下忙嘛，帮改一下程序

页: [1]

明经CAD社区's Archiver

[求助]

[VBA]谢谢你，有了你的帮忙程序终于运行出来了，可以再帮一下吗，再行行好吧ok？

两条直线怎么延伸到相交，不相交怎么办帮修改一下程序

[VBA]再帮一下忙嘛，帮改一下程序