【7.0.103】用Auto CAD制作GeoJson自定义地图经验帖

为摆脱在线转svg到GeoJson工具的每月3次转换限制，并且提高生成自定义地图的效率和区块之间位置、比例的准确性，尝试在Auto CAD内制作VBA工程，并通过CAD VBA工程从CAD工程文件导出自定义地图（area）和点（point）对象为txt文件，然后通过记事本或者Visual Studio简单编辑txt文件，最后修改文件后缀名为json即可：
1. 在CAD的”模型“编辑框内，使用多段线绘制出各个封闭区块；

2. 在CAD的Visual Basic编辑器内贴入以下代码，并运行，导出txt文件：
有两个函数，分别用于导出区块和点两种对象，注意红色加粗内容是导出文件保存位置，需要自行修改
Sub 导出多段线对象坐标到txt文件再转GeoJson文件作为area文件()
    Dim Ent As Object
    Dim getDpts As Variant
    Dim 每个点坐标前字符串 As String
    Dim 每个点坐标后字符串 As String
    Dim 坐标x As String
    Dim 坐标y As String
    Open "i:\alltext.txt" For Append As #1
    Print #1, "{""type"": ""FeatureCollection"",""creator"": ""xyz_2019"",""name"": ""DSXGZD"",""features"": ["
    每个点坐标前字符串名字前 = "{ ""type"": ""Feature"", ""properties"": { ""name"": """
    每个点坐标前字符串名字后 = """}, ""geometry"": { ""type"": ""Polygon"", ""coordinates"": [ [ "
    每个点坐标后字符串 = "] ] } },"
    j = 1
    For Each Ent In ThisDrawing.ModelSpace
        If Ent.ObjectName = "AcDbPolyline" Then
            If j = 1 Then
                Print #1, 每个点坐标前字符串名字前 & "坝体轮廓" & 每个点坐标前字符串名字后
            ElseIf j = 2 Then
                Print #1, 每个点坐标前字符串名字前 & "坝轴线" & 每个点坐标前字符串名字后
            Else
                Print #1, 每个点坐标前字符串名字前 & CStr(j - 2) & 每个点坐标前字符串名字后
            End If      
            getDpts = Ent.Coordinates
            For i = 0 To UBound(Ent.Coordinates) \ 2
                If Left(getDpts(i * 2), 1) = "." Then
                    坐标x = "0" & getDpts(i * 2)
                Else
                    坐标x = getDpts(i * 2)
                End If
                If Left(getDpts(i * 2 + 1), 1) = "." Then
                    坐标y = "0" & getDpts(i * 2 + 1)
                Else
                    坐标y = getDpts(i * 2 + 1)
                End If
                If i < UBound(Ent.Coordinates) \ 2 Then
                    Print #1, "[" & 坐标x & ", " & 坐标y & " ],"
                Else
                    Print #1, "[" & 坐标x & ", " & 坐标y & " ]"
                End If
            Next i
            Print #1, 每个点坐标后字符串
        End If
        j = j + 1
    Next Ent
    Print #1, "] }"
    Close #1
    MsgBox "已完成"
End Sub

Sub 导出点对象坐标到txt文件再转GeoJson文件作为point文件()
    Dim Ent As Object
    Dim getDpts As Variant
    Dim 每个点坐标前字符串 As String
    Dim 每个点坐标后字符串 As String
    Open "i:\alltext.txt" For Append As #1
    Print #1, "{""type"": ""FeatureCollection"", ""features"": ["
    每个点坐标前字符串 = "{ ""type"": ""Feature"", ""properties"": { ""name"": ""N""}, ""geometry"": { ""type"": ""Point"", ""coordinates"": [ "
    每个点坐标后字符串 = "] } },"
    For Each Ent In ThisDrawing.ModelSpace
        If Ent.ObjectName = "AcDbPoint" Then
            Print #1, 每个点坐标前字符串
            getDpts = Ent.Coordinates
            Print #1, "[" & getDpts(0) & ", " & getDpts(1) & " ]"
            Print #1, 每个点坐标后字符串
        End If
    Next Ent
    Print #1, "] }"
    Close #1
    MsgBox "已完成"
End Sub
3. 用记事本或者Visual Studio打开导出的txt文件，进行编辑和修改：
主要是修改区块的名称，并排除结尾的一个语法瑕疵。

4. 最后修改文件名格式
区块对象格式为”******_area.json“，点对象格式为”******_point.json“，复制到这个文件夹就可以用了

5. 可能需要多次尝试，才能呈现最理想的自定义地图：

以上为个人经验，或有不足之处，请多指导交流。

好多年没看VBA语法了，给大佬点赞

感谢大佬分享
这个帖子不加精版主拉去修长城好吧

以往相关讨论内容：
1. yikai，https://gcdn.grapecity.com.cn/showtopic-69056-1-1.html，https://gcdn.grapecity.com.cn/showtopic-69010-1-1.html
2. 钟海东，https://gcdn.grapecity.com.cn/showtopic-80496-1-1.html

谢厅 发表于 2022-6-13 17:25
感谢大佬分享
这个帖子不加精版主拉去修长城好吧

向谢老板学习！

高手如云呀，，，赞一个

虽然看不懂