沙漠骆驼工具箱源码-7导出多段线顶点坐标

woxing1987

工具条：批量打印，界面和代码如下：
1 界面：



2 代码如下：

Option Explicit '强制要求变量声明
Dim xzuobiao() As Double   '定义x,y,z坐标
Dim yzuobiao() As Double
Dim zzuobiao() As Double
'Dim duoduanxian As AcadLWPolyline '为轻量多段线
Dim duoduanxian As AcadEntity
Dim dingdiangcount As Long

Private Sub CommandButton1_Click()
    Me.Hide
    ThisDrawing.SendCommand "wh_lkx" & vbCr
    On Error Resume Next
    Dim base As Variant
    ThisDrawing.Utility.GetEntity duoduanxian, base, vbCrLf & "请拾取要导出顶点坐标的多段线:"
    If Err.Number <> 0 Or duoduanxian.ObjectName <> "AcDbPolyline" _
              And duoduanxian.ObjectName <> "AcDb3dPolyline" _
               And duoduanxian.ObjectName <> "AcDb2dPolyline" Then
        ThisDrawing.Utility.prompt "-----多段线拾取失败------" & vbCrLf
        Me.show
        Err.Clear
        TextBox3.Text = "" '清空文本框
        Exit Sub
    End If
    'duoduanxian.Elevation = 0 '将平面线标高归零，以便后面使用
    ThisDrawing.Utility.prompt "-----多段线拾取成功------" & vbCrLf
    duoduanxian.Highlight True
'==============================
    dingdiangcount = getvertexcount(duoduanxian) '获取顶点个数
    TextBox3.Text = "" '清空文本框
    Dim i As Long
    ReDim xzuobiao(dingdiangcount - 1)
    ReDim yzuobiao(dingdiangcount - 1)
    ReDim zzuobiao(dingdiangcount - 1)
    For i = 0 To dingdiangcount - 1
        xzuobiao(i) = duoduanxian.Coordinate(i)(0)
        yzuobiao(i) = duoduanxian.Coordinate(i)(1)
        If duoduanxian.ObjectName <> "AcDb3dPolyline" Then
            zzuobiao(i) = duoduanxian.Elevation
        Else
            zzuobiao(i) = duoduanxian.Coordinate(i)(2)
        End If
        TextBox3.Text = TextBox3.Text & Format(i + 1, "!@@@@@") & Format(",", "!@@") & _
                        Format(xzuobiao(i), "0.0000") & Format(",", "!@@") & _
                        Format(yzuobiao(i), "0.0000") & Format(",", "!@@") & _
                        Format(zzuobiao(i), "0.0000") & vbCr
        ThisDrawing.Utility.prompt "正在处理第 " & i & " 个顶点" & vbCrLf
    Next i
    ThisDrawing.Utility.prompt "共处理了" & i - 1 & " 个顶点" & vbCrLf
    Me.show
End Sub


Private Sub CommandButton2_Click() '导出(txt文本)
    'On Error Resume Next '错误继续执行
    If dingdiangcount = 0 Then
        MsgBox "请先拾取多段线!", vbCritical
        Exit Sub
    End If
    Static bianhao As Integer
    bianhao = bianhao + 1
    Dim i As Long
    'MsgBox dingdiangcount
    Open "c:\多段线顶点坐标" & bianhao & ".txt" For Output As #3    '新建文件
    For i = 0 To dingdiangcount - 1 '文件读取循环  'text的每一行数据都为一个整体字符型数据，
        If CheckBox1.value And CheckBox2.value Then '交换xy,保存z坐标
            Print #3, i + 1 & "," & Format(yzuobiao(i), "0.0000") & _
                              "," & Format(xzuobiao(i), "0.0000") & _
                              "," & Format(zzuobiao(i), "0.0000")
        ElseIf CheckBox1.value And CheckBox2.value = False Then  '交换xy,不保存z坐标
            Print #3, i + 1 & "," & Format(yzuobiao(i), "0.0000") & _
                              "," & Format(xzuobiao(i), "0.0000")
        ElseIf CheckBox1.value = False And CheckBox2.value Then  '不交换xy,保存z坐标
            Print #3, i + 1 & "," & Format(xzuobiao(i), "0.0000") & _
                              "," & Format(yzuobiao(i), "0.0000") & _
                              "," & Format(zzuobiao(i), "0.0000")
        ElseIf CheckBox1.value = False And CheckBox2.value = False Then '不交换xy,不保存z坐标
            Print #3, i + 1 & "," & Format(xzuobiao(i), "0.0000") & _
                              "," & Format(yzuobiao(i), "0.0000")
        End If
    Next '文件读取循环
    Close #3  '关闭文件
    MsgBox "以存储在c:\多段线顶点坐标" & bianhao & ".txt"
    duoduanxian.Highlight False
End Sub


Private Sub CommandButton3_Click()
    Me.Hide
End Sub