三顾草庐获取CAD中线的每个节点坐标程序设计

2021年1月20日发(作者：谈立人)
^`
获取
CAD
中线的每个节点坐标程序设计（一）


获取
CAD
中线的每个节点坐标，线包括
polyline
、
3D polyline
、
Spline
等等！


程序代码如下：



Imports System
Imports
Imports
Public Class
获取
CAD
中点坐标

Public AcadApp As plication
Public xx(), yy(), zz() As Double
Public Count As Integer
Public returnObj As Object
Public FolderPath As String =
Public StepNum As Integer = 0
Private Declare Auto Function SetProcessWorkingSetSize Lib
(ByVal procHandle As IntPtr, ByVal min As Int32, ByVal max As Int32) As
Boolean
Public Sub SetProcessWorkingSetSize()
'
节约系统内存

Try
Dim Mem As Process
Mem = rentProcess()
SetProcessWorkingSetSize(, -1, -1)
Catch ex As Exception
MsgBox(ng)
End Try
End Sub
Public Sub
启动
CAD()
On Error Resume Next
AcadApp = GetObject(,
If Then
()
AcadApp = CreateObject(
End If
^`
e = True
State =
AppActivate(n)
End Sub
Public Sub
获取样条线节点坐标
()
Dim i As Integer
For i = 0 To 10000 Step StepNum
On Error GoTo handle01
Count = i
ReDim Preserve xx(i)
ReDim Preserve yy(i)
ReDim Preserve zz(i)
xx(i) = nate(i)(0)
yy(i) = nate(i)(1)
zz(i) = ion
Next
handle01:
Count = Count - 1
End Sub
Public Sub
获取
Spline
线节点坐标
()
Dim fitPoints As Object
Dim i As Integer
For i = 0 To OfControlPoints - 1 Step StepNum
fitPoints = trolPoint(i)
Count = i
ReDim Preserve xx(i)
ReDim Preserve yy(i)
ReDim Preserve zz(i)
xx(i) = fitPoints(0)
yy(i) = fitPoints(1)
zz(i) = fitPoints(2)
Next
End Sub
Public Sub
获取
Spline
线拟合点坐标
()
Dim fitPoints As Object
^`
Dim pp As line
Dim i As Integer
For i = 0 To OfFitPoints - 1 Step StepNum
fitPoints = Point(i)
Count = i
ReDim Preserve xx(i)
ReDim Preserve yy(i)
ReDim Preserve zz(i)
xx(i) = fitPoints(0)
yy(i) = fitPoints(1)
zz(i) = fitPoints(2)
Next
End Sub

Public Sub
获取
line
线节点坐标
()
Dim StartPoints As Object
Dim EndPoints As Object
ReDim Preserve xx(1)
ReDim Preserve yy(1)
ReDim Preserve zz(1)
Count = 1
ght(True)
StartPoints = oint
EndPoints = nt
xx(0) = StartPoints(0)
yy(0) = StartPoints(1)
zz(0) = StartPoints(2)
xx(1) = EndPoints(0)
yy(1) = EndPoints(1)
zz(1) = EndPoints(2)
End Sub
Public Sub
获取
2DPolyline
节点坐标
()
'Dim sss As Polyline
ght(True)
Dim i As Integer
^`
For i = 0 To 10000 Step StepNum
On Error GoTo handle01
Count = i
ReDim Preserve xx(i)
ReDim Preserve yy(i)
ReDim Preserve zz(i)
xx(i) = nate(i)(0)
yy(i) = nate(i)(1)
zz(i) = ion
Next
handle01:
Count = Count - 1
End Sub
Private Sub Button1_Click(ByVal sender As , ByVal e As
rgs) Handles
On Error GoTo handle01
Call
启动
CAD()
Dim basePnt As Object
ity(returnObj, basePnt)
ght(True)
'
判断线的类型

Dim LineTypenName As String
LineTypenName = ng()
If LineTypenName =
Call
获取
line
线节点坐标
()
ElseIf LineTypenName =
Call
获取
Spline
线节点坐标
()
ElseIf LineTypenName =
Call
获取样条线节点坐标
()
Else : Exit Sub
End If
If <> 0 Or <> 0 Or <> 0
Then
Call CalculateCoordinate()
End If
^`
Dim i As Integer
Dim s As String =
For i = 0 To Count
s = s + xx(i).ToString() +
Chr(13)
Next
= s
d = True
AppActivate()
Exit Sub
handle01:
MsgBox(ption)
End Sub
Private Sub Button2_Click(ByVal sender As , ByVal e As
rgs) Handles
On Error GoTo handle01
Dim dg As New OpenFileDialog
=
alog()
Dim s As String = me
If s =

启动
CAD()
(s)
State =

AppActivate()
d = True
Exit Sub
handle01:
MsgBox(ption)
End Sub
Private Sub Button3_Click(ByVal sender As , ByVal e As
rgs) Handles
On Error GoTo handle01
Dim dg As New SaveFileDialog
^`
=
alog()
Dim s As String = me
Dim i As Integer
Dim s1 As String =
Using sw As StreamWriter = New StreamWriter(s)
For i = 0 To Count
s1 = xx(i).ToString() +
ine(s1)
Next
()
End Using
Exit Sub
handle01:
MsgBox(ption)
End Sub
Private Sub Button4_Click(ByVal sender As , ByVal e As
rgs) Handles
(veView
port)
End Sub
Public Sub CalculateCoordinate()
On Error GoTo handle01
Dim x0, y0, Rotangle As Double
x0 =
y0 =
Rotangle = () * 3.1415926 / 180
Dim i As Integer
Dim x1, y1 As Double
If Cos(Rotangle) = 0 Then
For i = 0 To Count
x1 = xx(i)
xx(i) = yy(i) - y0
yy(i) = x0 - x1
Next
^`
Exit Sub
End If
For i = 0 To Count
y1 = (yy(i) - y0 - (xx(i) - x0) * Tan(Rotangle)) * Cos(Rotangle)
x1 = (xx(i) - x0) / Cos(Rotangle) + y1 * Tan(Rotangle)
If Abs(x1) < 0.00001 Then x1 = 0 '
设置精度

If Abs(y1) < 0.00001 Then y1 = 0
xx(i) = x1
yy(i) = y1
Next
Exit Sub
handle01:
MsgBox(ption)
End Sub
Private Sub TextBox2_TextChanged(ByVal sender As ,
ByVal e As rgs) Handles anged
End Sub
Private Sub
批量获取节点坐标
Button_Click(ByVal sender As
, ByVal e As rgs) Handles
批量获取节点坐标

Static ExitNum As Integer
On Error GoTo handle01
Static SaveNum As Integer
Call
启动
CAD()
Dim basePnt As Object
ity(returnObj, basePnt)
ght(True)
mmand(
选取下一条线
!
连续在 空白
地方点击两次将会自动退出批量存储状态
!
'
判断线的类型

Dim LineTypenName As String
LineTypenName = ng()
If LineTypenName =
Call
获取
line
线节点坐标
()
ElseIf LineTypenName =
^`
Call
获取
Spline
线节点坐标
()
ElseIf LineTypenName =
Call
获取样条线节点坐标
()
End If
If <> 0 Or <> 0 Or <> 0
Then
Call CalculateCoordinate()
End If
Dim j As Integer
Dim s1 As String =
Using sw As StreamWriter = New StreamWriter(FolderPath +
ng() +
For j = 0 To Count
s1 = xx(j).ToString() +
ine(s1)
Next
()
SaveNum = SaveNum + 1
End Using
ExitNum = 0
Call
批量获取节点坐标
Button_Click(sender, e)
Exit Sub
handle01:
ExitNum = ExitNum + 1
If ExitNum = 2 Then
ExitNum = 0
Exit Sub
Else : Call
批量获取节点坐标
Button_Click(sender, e)
End If
End Sub
Private Sub
设置文件保存路径
Button5_Click(ByVal sender As
, ByVal e As rgs) Handles
设置文件保存路径

Dim fdg As FolderBrowserDialog
fdg = New FolderBrowserDialog
^`
alog()
If edPath =
FolderPath = edPath
End Sub
Private Sub Button5_Click(ByVal sender As , ByVal e As
rgs) Handles
On Error GoTo Handle01
Call
启动
CAD()
Dim sset As lectionSet
sset = (
'
提示用户选择对象

OnScreen()
Dim ent As Object
Dim sss As int
Count = -1
For Each ent In sset
If name =
Count = Count + 1
ReDim Preserve xx(Count)
ReDim Preserve yy(Count)
ReDim Preserve zz(Count)
xx(Count) = nates(0)
yy(Count) = nates(1)
zz(Count) = nates(2)
End If
Next ent
If <> 0 Or <> 0 Or <> 0
Then
Call CalculateCoordinate()
End If
Dim i As Integer
Dim s As String =
For i = 0 To Count
s = s + xx(i).ToString() +
Chr(13)
^`
Next
= s
(
e()
AppActivate()
d = True
Exit Sub
Handle01:
(
e()
Button5_Click(sender, e)
MsgBox(ption)
End Sub
Private Sub Button6_Click_1(ByVal sender As , ByVal e As
rgs) Handles
On Error GoTo Handle01
()
Handle01:
MsgBox(ption)
End Sub
Private Sub Button7_Click(ByVal sender As , ByVal e As
rgs) Handles
Call
启动
CAD()
Dim basePnt As Object
ity(returnObj, basePnt)
ght(True)
AppActivate(n)
Dim i As Integer
For i = 0 To 500
On Error GoTo handle01
Count = i
ReDim Preserve xx(i)
ReDim Preserve yy(i)
ReDim Preserve zz(i)
xx(i) = nate(i)(0)
^`
yy(i) = nate(i)(1)
zz(i) = nate(i)(2)
Next
handle01:
Count = Count - 1
Dim j As Integer
Dim s As String =
For j = 0 To Count
s = s + xx(j).ToString() +
Chr(13)
Next
= s
d = True
AppActivate()
End Sub
Private Sub Form1_Load(ByVal sender As , ByVal e As
rgs) Handles
Call SetProcessWorkingSetSize()
End Sub
Private Sub Button8_Click(ByVal sender As , ByVal e As
rgs) Handles
On Error GoTo handle01
Call
启动
CAD()
Dim basePnt As Object
ity(returnObj, basePnt)
ght(True)
Call
获取
2DPolyline
节点坐标
()
If <> 0 Or <> 0 Or <> 0
Then
Call CalculateCoordinate()
End If
Dim i As Integer
Dim s As String =
For i = 0 To Count
s = s + xx(i).ToString() +