AutoCAD VBA函数---坐标展点

Public Sub mAddPointToMap() '注:strOperate=strDivide

Dim cdgSelect As New CommonDialog

Dim FileNo As Integer

Dim strLine As String

Dim objPnt As AcadPoint

Dim dblPnt(0 To 2) As Double

Dim objTxt As AcadText

Dim dblTxt(0 To 2) As Double

Dim mLyr As AcadLayer, blnLyr As Boolean

Dim intCnt As Integer

With cdgSelect

.DialogTitle = "选择展点文件(点名,代码,东坐标,北坐标,高程)"

.filter = "展点文件(*.CSV)|*.CSV|CASS展点文件(*.DAT)|*.DAT"

.ShowOpen

If .FileName = "" Then

ThisDrawing.Utility.Prompt vbCr & "未选择展点文件。"

Exit Sub

End If

If Dir(.FileName) = "" Then

ThisDrawing.Utility.Prompt vbCr & "未找到展点文件" & .FileName

Exit Sub

End If

blnLyr = False

For Each mLyr In https://www.wendangku.net/doc/1a4584838.html,yers

If https://www.wendangku.net/doc/1a4584838.html, = "mPoint" Then

blnLyr = True

Exit For

End If

Next

If blnLyr = False Then

https://www.wendangku.net/doc/1a4584838.html,yers.Add ("mPoint")

End If

blnLyr = False

For Each mLyr In https://www.wendangku.net/doc/1a4584838.html,yers

If https://www.wendangku.net/doc/1a4584838.html, = "mPointID" Then

blnLyr = True

Exit For

End If

Next

If blnLyr = False Then

https://www.wendangku.net/doc/1a4584838.html,yers.Add ("mPointID")

End If

blnLyr = False

For Each mLyr In https://www.wendangku.net/doc/1a4584838.html,yers

If https://www.wendangku.net/doc/1a4584838.html, = "mPointCode" Then

blnLyr = True

Exit For

End If

Next

If blnLyr = False Then

https://www.wendangku.net/doc/1a4584838.html,yers.Add ("mPointCode")

End If

blnLyr = False

For Each mLyr In https://www.wendangku.net/doc/1a4584838.html,yers

If https://www.wendangku.net/doc/1a4584838.html, = "mPointH" Then

blnLyr = True

Exit For

End If

Next

If blnLyr = False Then

https://www.wendangku.net/doc/1a4584838.html,yers.Add ("mPointH")

End If

FileNo = FreeFile

Open .FileName For Input As FileNo

Do While Not EOF(FileNo)

Line Input #FileNo, strLine

If strOperate(strLine, ",").Count = 5 Then

intCnt = intCnt + 1

dblPnt(0) = CDbl(strOperate(strLine, ",").Data(2))

dblPnt(1) = CDbl(strOperate(strLine, ",").Data(3))

dblPnt(2) = CDbl(strOperate(strLine, ",").Data(4))

Set objPnt = ThisDrawing.Application.ActiveDocument.ModelSpace.AddPoint(dblPnt)

https://www.wendangku.net/doc/1a4584838.html,yer = "mPoint"

objPnt.Update

dblTxt(0) = dblPnt(0) + 1

dblTxt(1) = dblPnt(1) - 1.75

dblTxt(2) = dblPnt(2)

Set objTxt = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(strOperate(strLine, ",").Data(0), dblTxt, 3.5)

https://www.wendangku.net/doc/1a4584838.html,yer = "mPointID"

objTxt.Update

Set objTxt = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(strOperate(strLine, ",").Data(1), dblTxt, 3.5)

https://www.wendangku.net/doc/1a4584838.html,yer = "mPointCode"

objTxt.Update

Set objTxt = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(strOperate(strLine, ",").Data(4), dblTxt, 3.5)

https://www.wendangku.net/doc/1a4584838.html,yer = "mPointH"

objTxt.Update

End If

Loop

Close FileNo

End With

ThisDrawing.Utility.Prompt vbCr & "展点完毕,共展点" & intCnt & "个。"

End Sub