NOVOTS KMS 词汇表 Glossary    联系我们 Contact Us
查询 Search  
   
按类别浏览 Browse by Category
NOVOTS KMS .: 工具软件 .: AutoCAD VBA函数---坐标展点

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 ThisDrawing.Layers

         If mLyr.Name = "mPoint" Then

            blnLyr = True

            Exit For

         End If

     Next

     If blnLyr = False Then

        ThisDrawing.Application.ActiveDocument.Layers.Add ("mPoint")

     End If

     blnLyr = False

     For Each mLyr In ThisDrawing.Layers

         If mLyr.Name = "mPointID" Then

            blnLyr = True

            Exit For

         End If

     Next

     If blnLyr = False Then

        ThisDrawing.Application.ActiveDocument.Layers.Add ("mPointID")

     End If

     blnLyr = False

     For Each mLyr In ThisDrawing.Layers

         If mLyr.Name = "mPointCode" Then

            blnLyr = True

            Exit For

         End If

     Next

     If blnLyr = False Then

        ThisDrawing.Application.ActiveDocument.Layers.Add ("mPointCode")

     End If

     blnLyr = False

     For Each mLyr In ThisDrawing.Layers

         If mLyr.Name = "mPointH" Then

            blnLyr = True

            Exit For

         End If

     Next

     If blnLyr = False Then

        ThisDrawing.Application.ActiveDocument.Layers.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)

             objPnt.Layer = "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)

             objTxt.Layer = "mPointID"

             objTxt.Update

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

             objTxt.Layer = "mPointCode"

             objTxt.Update

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

             objTxt.Layer = "mPointH"

             objTxt.Update

         End If

       Loop

     Close FileNo

  End With

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

End Sub


这篇文章对你多有用?

相关文章

article 使用管理员账号安装Autocad 2010激活案例
      ...

(No rating)  9-12-2012    Views: 1230   
article AutoCAD 快捷键
  运行 Visual Basic 应用程序的编辑器...

(No rating)  8-25-2012    Views: 1214   
article AutoCAD 缺少dfst.dll文件
安装AUTOCAD2007时提示缺少dfst.dll文件 ...

  10-29-2010    Views: 3528   

用户评语

添加评语
当前还没有评语.


.: .: .: .: .:
[ 登陆 ]
北京护航科技有限公司 2006

Novots Technologies Limited