方格网数据批量提取

第一步  复制下列代码到vba编辑器内。

Public Sub TQWZ()

 Dim sSet As AcadSelectionSet

 For Each sSet In ThisDrawing.Application.ActiveDocument.SelectionSets

     If sSet.Name = "TQWZ" Then sSet.Delete: Exit For

 Next

 Set sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add("TQWZ")

 Dim mType(0) As Integer, mData(0) As Variant

 mType(0) = 0: mData(0) = "TEXT"

 sSet.SelectOnScreen mType, mData

 If sSet.Count > 0 Then

    Dim objText As AcadText, FileNo As Integer, i As Integer

    FileNo = FreeFile

    Dim txtFile As String

    txtFile = "d:\TQWZ" & Year(Now) & Format(Month(Now), "00") & Format(Day(Now), "00") & Format(Hour(Now), "00") & Format(Minute(Now), "00") & Format(Second(Now), "00") & ".txt"

    Open txtFile For Append As #FileNo

    Print #FileNo, "序号,东坐标,北坐标,文字内容"

    For Each objText In sSet

        i = i + 1

        Print #FileNo, i & "," & objText.InsertionPoint(0) & "," & objText.InsertionPoint(1) & "," & objText.TextString

    Next

    Close #FileNo

 End If

 sSet.Delete

 MsgBox "ok", vbInformation, "提取文字"

 Shell "explorer.exe /select," & txtFile, vbNormalFocus

End Sub

第三步  用excel给提取出来的坐标加个常数（常数可以自己在cad中量取或计算），使它与格网坐标对应，然后保存为dat文件，完成。

你好，到下载中心下载插件可以提取

http://o.southgis.com/download/init?pid=f86d9b68-1388-4b7a-8ede-10e241ff1d13