沙漠骆驼工具箱源码-10 坐标标注

woxing1987

工具条：坐标标注，界面和代码如下：
1 界面：



2 代码如下：


'Option Explicit '要求变量声明
Private Type xyzzuobiao
    x As Double
    y As Double
    z As Double
End Type
Dim dianzuobiao() As xyzzuobiao '定义坐标
Dim zuobiaogeshu As Integer '定义坐标点个数
Dim xiaoshuweishu As Integer
Dim zigao As Single
Dim layerobj As AcadLayer
Dim currentlayername As String
Dim currentcolor As String
Dim currenttextstyle As String
Dim qianzhui As String '编号的前缀




Private Sub CommandButton1_Click() '插入坐标
    'Me.Hide
    ThisDrawing.SendCommand "whlkx" & vbCr '用来防止按钮坏死，就是不能用了
    currentlayername = ThisDrawing.ActiveLayer.name
    currentcolor = ThisDrawing.GetVariable("cecolor")
    Set layerobj = ThisDrawing.Layers.Add("坐标标注")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    layerobj.color = 95
    ThisDrawing.SetVariable "cecolor", "95"
    ThisDrawing.ActiveLayer = layerobj
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
   
    Dim zigao As Single   '字体高度
    Dim xiaoshuweishu As Integer '定义小数位数
    Dim geshi As String
    Dim zuobiaox As Double '定义坐标x,y,z
    Dim zuobiaoy As Double
    Dim zuobiaoz As Double
    Dim textx As AcadText 'x坐标
    Dim texty As AcadText
    Dim textz As AcadText
   
    'Dim basepoint As Variant
    zigao = ComboBox1.Text
    xiaoshuweishu = ComboBox3.Text
    qianzhui = ComboBox4.Text
    Dim charudian1 As Variant
    Dim weizhi(0 To 2) As Double
    Dim xianshidian As AcadCircle
    On Error GoTo e1
    Dim linshidian(0 To 2) As Double
    linshidian(0) = 0: linshidian(1) = 0: linshidian(2) = 0
   
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(linshidian, 1) '先随便画一个圆，一个小小的技巧
r1:
    charudian1 = ThisDrawing.Utility.GetPoint(, "拾取任意一点(按esc键退出):")
   
    ReDim Preserve dianzuobiao(zuobiaogeshu)   'preserve 更新数组的大小，且保留之前的数据
    zuobiaox = charudian1(0)
    zuobiaoy = charudian1(1)
    zuobiaoz = charudian1(2)
    dianzuobiao(zuobiaogeshu).x = zuobiaox
    dianzuobiao(zuobiaogeshu).y = zuobiaoy
    dianzuobiao(zuobiaogeshu).z = zuobiaoz
   
    xianshidian.Delete
    Set xianshidian = ThisDrawing.ModelSpace.AddCircle(charudian1, zigao)
    xianshidian.color = acRed
    xianshidian.Highlight True
   
    If xiaoshuweishu = 0 Then
        geshi = "0"
    Else
        geshi = "0." & Right("00000", xiaoshuweishu)
    End If
    weizhi(0) = charudian1(0) + zigao
    weizhi(1) = charudian1(1) + 1.5 * zigao
    If CheckBox1.value Then Set textx = ThisDrawing.ModelSpace.AddText("X: " & Format(zuobiaox, geshi), weizhi, zigao)
   
    weizhi(0) = charudian1(0) + zigao
    weizhi(1) = charudian1(1)
    If CheckBox2.value Then Set texty = ThisDrawing.ModelSpace.AddText("Y: " & Format(zuobiaoy, geshi), weizhi, zigao)
   
    weizhi(0) = charudian1(0) + zigao
    weizhi(1) = charudian1(1) - 1.5 * zigao
    If CheckBox3.value Then Set textz = ThisDrawing.ModelSpace.AddText("Z: " & Format(zuobiaoz, geshi), weizhi, zigao)
    ThisDrawing.ModelSpace.AddCircle charudian1, zigao / 2
    'TextBox3.Text & Format(xuhao, "!@@@@") & Format(",", "!@@@@") & shujudian(0) & Format(",", "!@@@@@@") & shujudian(1) & Format(",", "!@@@@@@") & shujudian(2) & vbCr
   
    zuobiaogeshu = zuobiaogeshu + 1 '坐标个数加1
    Dim dianxuhao As AcadText
    weizhi(0) = charudian1(0) - zigao * 0.7
    weizhi(1) = charudian1(1)
    Set dianxuhao = ThisDrawing.ModelSpace.AddText(qianzhui & zuobiaogeshu, weizhi, zigao)
    With dianxuhao
        .Alignment = acAlignmentMiddleRight
        .TextAlignmentPoint = weizhi
    End With
    '向列表框内添加坐标
    ListBox1.AddItem qianzhui & zuobiaogeshu & Format(",", "!@@") & Round(zuobiaox, xiaoshuweishu) & Format(",", "!@@") & _
               Round(zuobiaoy, xiaoshuweishu) & Format(",", "!@@") & Round(zuobiaoz, xiaoshuweishu)
   
    ListBox1.Selected(zuobiaogeshu - 1) = True
   
'    Dim groupobj As AcadGroup '定义组对象
'    Dim appendobjs(0 To 2) As AcadEntity
'
'    Set appendobjs(0) = textx
'    Set appendobjs(1) = texty
'    Set appendobjs(2) = textz
'    Set groupobj = ThisDrawing.Groups.Add("*")
'    groupobj.AppendItems appendobjs
e1:
    If Err.Number <> 0 Then
        Err.Clear
        '重置系统变量
        ThisDrawing.SetVariable "cecolor", currentcolor '恢复绘图颜色
        ThisDrawing.SetVariable "textstyle", currenttextstyle
        '恢复图层
        ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
        'Me.Show
        xianshidian.Delete
        Exit Sub
    Else
        GoTo r1
    End If
End Sub


Private Sub CommandButton2_Click()
    Me.Hide
    Exit Sub
End Sub


Private Sub CommandButton3_Click() '插入坐标表
    'quxiao '调用取消命令
    'ThisDrawing.SendCommand "whlkx" & vbCr '用来防止按钮坏死，就是不能用了
    If zuobiaogeshu = 0 Then
        MsgBox "坐标点个数为0，请先获取点坐标！"
        Exit Sub
    End If
   
    currentlayername = ThisDrawing.ActiveLayer.name
    currentcolor = ThisDrawing.GetVariable("cecolor")
    Set layerobj = ThisDrawing.Layers.Add("坐标标注")
    currenttextstyle = ThisDrawing.GetVariable("textstyle")
    layerobj.color = 95
    ThisDrawing.SetVariable "cecolor", "95"
    ThisDrawing.ActiveLayer = layerobj
'    newtextstyle2    '调用新建字体样式程序
'    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    Me.Hide
    zigao = ComboBox1.Text
    Dim basepoint As Variant
    basepoint = ThisDrawing.Utility.GetPoint(, "拾取统计表格插入点:")
     '画表格
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
   
    Dim biaotoukuan As Double '设定 表格宽度
    Dim biaotougao As Double '设定 表格高度
    If zigao < 4 Then
        biaotoukuan = 20
        biaotougao = 8
    Else
        biaotoukuan = zigao * 8
        biaotougao = zigao * 2.5
    End If
    Dim hengxian As AcadLWPolyline
    Dim p1p2(0 To 3) As Double
    Dim i As Integer
    p1p2(0) = basepoint(0): p1p2(1) = basepoint(1)
    p1p2(2) = basepoint(0) + 4 * biaotoukuan: p1p2(3) = p1p2(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    p1p2(0) = basepoint(0): p1p2(1) = basepoint(1) - biaotougao
    p1p2(2) = basepoint(0) + 4 * biaotoukuan: p1p2(3) = p1p2(1)
    ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
   
    For i = 0 To UBound(dianzuobiao)
        p1p2(0) = basepoint(0): p1p2(1) = p1p2(1) - biaotougao
        p1p2(2) = basepoint(0) + 4 * biaotoukuan: p1p2(3) = p1p2(1)
        ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    Next
    For i = 0 To 4
        p1p2(0) = basepoint(0) + biaotoukuan * i
        p1p2(1) = basepoint(1)
        p1p2(2) = p1p2(0)
        ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
    Next
   
'    Dim p2p4(0 To 7) As Double
'    p2p4(0) = basepoint(0): p2p4(1) = p1p2(3)
'    p2p4(2) = basepoint(0): p2p4(3) = p1p2(3) - biaotougao
'    p2p4(4) = basepoint(0) + 4 * biaotoukuan: p2p4(5) = p2p4(3)
'    p2p4(6) = p2p4(4): p2p4(7) = p2p4(1)
'    ThisDrawing.ModelSpace.AddLightWeightPolyline p2p4
   
    Dim mingcheng As AcadText
    Dim charudian(0 To 2) As Double
    charudian(0) = basepoint(0) + biaotoukuan * 0.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("序 号", charudian, zigao)
    With mingcheng
        .Alignment = acAlignmentMiddleCenter
        .TextAlignmentPoint = charudian
    End With
    charudian(0) = basepoint(0) + biaotoukuan * 1.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("x坐标", charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    charudian(0) = basepoint(0) + biaotoukuan * 2.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("y坐标", charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    charudian(0) = basepoint(0) + biaotoukuan * 3.5
    charudian(1) = basepoint(1) - biaotougao * 0.5
    Set mingcheng = ThisDrawing.ModelSpace.AddText("z坐标", charudian, zigao)
    mingcheng.Alignment = acAlignmentMiddleCenter
    mingcheng.TextAlignmentPoint = charudian
   
    xiaoshuweishu = ComboBox3.Text
    '插入编号及x y z 坐标
    For i = 1 To UBound(dianzuobiao) + 1
        charudian(0) = basepoint(0) + biaotoukuan * 0.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(qianzhui & i, charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
        
        charudian(0) = basepoint(0) + biaotoukuan * 1.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(Round(dianzuobiao(i - 1).x, xiaoshuweishu), charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
        
        charudian(0) = basepoint(0) + biaotoukuan * 2.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(Round(dianzuobiao(i - 1).y, xiaoshuweishu), charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
        
        charudian(0) = basepoint(0) + biaotoukuan * 3.5
        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
        Set mingcheng = ThisDrawing.ModelSpace.AddText(Round(dianzuobiao(i - 1).z, xiaoshuweishu), charudian, zigao)
        mingcheng.Alignment = acAlignmentMiddleCenter
        mingcheng.TextAlignmentPoint = charudian
    Next
'    For i = 1 To UBound(dianzuobiao) + 1
'        charudian(0) = basepoint(0) + biaotoukuan * 1.5
'        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
'        Set mingcheng = ThisDrawing.ModelSpace.AddText(danwei, charudian, zigao)
'        mingcheng.Alignment = acAlignmentMiddleCenter
'        mingcheng.TextAlignmentPoint = charudian
'    Next
'    For i = 1 To UBound(dianzuobiao) + 1
'        charudian(0) = basepoint(0) + biaotoukuan * 2.5
'        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
'        Set mingcheng = ThisDrawing.ModelSpace.AddText(danwei, charudian, zigao)
'        mingcheng.Alignment = acAlignmentMiddleCenter
'        mingcheng.TextAlignmentPoint = charudian
'    Next
'    For i = 1 To UBound(dianzuobiao) + 1
'        charudian(0) = basepoint(0) + biaotoukuan * 3.5
'        charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
'        Set mingcheng = ThisDrawing.ModelSpace.AddText(danwei, charudian, zigao)
'        mingcheng.Alignment = acAlignmentMiddleCenter
'        mingcheng.TextAlignmentPoint = charudian
'    Next


    charudian(0) = basepoint(0)
    charudian(1) = basepoint(1) + biaotougao * 0.5


    Set mingcheng = ThisDrawing.ModelSpace.AddText("坐标点个数为:" & zuobiaogeshu & "  By 沙漠骆驼(WHLKX)", charudian, zigao)
    Me.show
    '重置系统变量
        ThisDrawing.SetVariable "cecolor", currentcolor '恢复绘图颜色
        ThisDrawing.SetVariable "textstyle", currenttextstyle
        '恢复图层
        ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
End Sub


Private Sub CommandButton4_Click()
    zuobiaogeshu = 0
    Erase dianzuobiao
    ListBox1.Clear
End Sub


Private Sub CommandButton5_Click() '保存数据，为excel格式
    Static jiludian As Integer '定义表格数据插入点
    jiludian = jiludian + 1
    On Error Resume Next
    '连接excel
    Dim excelfile As Object   '以防找不到工程或库，
    Dim excelbook As Object
    Dim excelsheet As Object
'    Dim excelfile As excel.Application
'    Dim excelbook As excel.Workbook
'    Dim excelsheet As excel.Worksheet
   
    Set excelfile = GetObject(, "excel.application")
    If Err <> 0 Then
        Err.Clear
        Set excelfile = CreateObject("excel.application")
        If Err <> 0 Then
            MsgBox "无法启动excel!", vbInformation
            Exit Sub
        End If
    End If
    '创建一个新工作簿
    'MsgBox excelfile.Sheets.count
    'MsgBox ActiveWorkbook.Sheets.count
    If excelfile.Sheets.count = 0 Then excelfile.Workbooks.Add
    Set excelbook = excelfile.ActiveWorkbook
    '确保Sheet1工作表为当前工作表
    Set excelsheet = excelbook.ActiveSheet
    'MsgBox excelsheet.Cells(jiludian, 1)
    If excelsheet.Cells(jiludian, 1) <> Null Then
        Set excelbook = excelfile.Workbooks.Add
        Set excelsheet = excelfile.ActiveSheet
    End If
    If Err <> 0 Then Err.Clear
   
    Dim i As Integer
    Dim j As Integer
    'excelsheet.Cells(1, 1).Font.ColorIndex = 1
'    For i = jiludian To jiludian + zuobiaogeshu '单元格居中
'        For j = 1 To 4
'            excelsheet.Cells(i, j).HorizontalAlignment = xlCenter
'        Next
'    Next
    For i = jiludian + 1 To jiludian + zuobiaogeshu
        For j = 2 To 4
            excelsheet.Cells(i, j).NumberFormat = "#0.00" '设置单元格显示精度
        Next
    Next
    excelsheet.Cells(jiludian, 1) = "序号"
    excelsheet.Cells(jiludian, 2) = "x坐标"
    excelsheet.Cells(jiludian, 3) = "y坐标"
    excelsheet.Cells(jiludian, 4) = "z坐标"
   
    Dim yuanshuju As Integer  '用于存储插入点单元格行号
    yuanshuju = jiludian
    For i = jiludian + 1 To jiludian + zuobiaogeshu  '
        excelsheet.Cells(i, 1) = qianzhui & i - yuanshuju
        excelsheet.Cells(i, 2) = dianzuobiao(i - yuanshuju - 1).x
        excelsheet.Cells(i, 3) = dianzuobiao(i - yuanshuju - 1).y
        excelsheet.Cells(i, 4) = dianzuobiao(i - yuanshuju - 1).z
    Next
    jiludian = jiludian + zuobiaogeshu + 1 '记录点向下移动zuobiaogeshu个单元格
    excelsheet.Cells(jiludian, 1).Select
    '令Excel应用程序可见
    excelfile.Visible = True
    excelfile.WindowState = xlNormal
    excelfile.width = 400
    excelfile.height = 500
    'jiludian = 0 '归0
End Sub




Private Sub UserForm_Initialize()
    Dim i As Integer
    For i = 1 To 19  '设置字体高度
        ComboBox1.AddItem Format(i / 2 + 0.5, "0.0")
    Next
    For i = 15 To 95 Step 5  '15---95
        ComboBox1.AddItem i
    Next
    For i = 100 To 1000 Step 50 '100---500
        ComboBox1.AddItem i
    Next
   
    ComboBox3.AddItem 0
    ComboBox3.AddItem 1 '设置小数位数
    ComboBox3.AddItem 2
    ComboBox3.AddItem 3
    ComboBox3.AddItem 4
    ComboBox3.AddItem 5
   
    For i = 65 To 90  '编号前缀
        ComboBox4.AddItem Chr(i)
    Next
End Sub