AutoCAD2005_VBA编程学习笔记_001

'如果需要dvb源文件可以通知我

'作者qq:973490770

Option Explicit
Dim CurrentDrawingColor As Integer
Sub CreateLine() '创建一条直线
    Dim StartPoint(0 To 2) As Double
    Dim EndPoint(0 To 2) As Double
    StartPoint(0) = TxtStartPointX.Text
    StartPoint(1) = TxtStartPointY.Text
    StartPoint(2) = TxtStartPointZ.Text
    EndPoint(0) = TxtEndPointX.Text
    EndPoint(1) = TxtEndPointY.Text
    EndPoint(2) = TxtEndPointZ.Text
    With ThisDrawing.ModelSpace
        .AddLine StartPoint, EndPoint
        .Item(.Count - 1).Update
    End With
End Sub
Sub HighLightLastItemDrawn() '最后一条直线高亮显示
    With ThisDrawing.ModelSpace
            Select Case .Count
            Case 0
                MsgBox "图纸上还木有画直线呢亲！"
            Case Is > 0
                .Item(.Count - 1).Highlight True '必须update某个对象才能显示出上次执行高亮命令的效果。
            End Select
    End With
End Sub
Sub UnHighLightLastItemDrawn() '最后一条直线取消高亮显示
    With ThisDrawing.ModelSpace
        Select Case .Count
            Case 0
                MsgBox "图纸上还木有画直线呢亲！"
            Case Is > 0
                .Item(.Count - 1).Highlight False
        End Select
    End With
End Sub
Sub HighLightAllItems() '高亮显示所有直线
    Dim HighLightAllItemsNum As Integer
    With ThisDrawing.ModelSpace
    Select Case .Count
    Case 0
        MsgBox "图纸上还木有画直线呢亲！"
    Case Is > 0
        For HighLightAllItemsNum = 0 To .Count - 1
            .Item(HighLightAllItemsNum).Highlight True
        Next
    End Select
    End With
End Sub
Sub UnHighLightAllItems() '取消所有直线高亮显示
    Dim LineObject As AcadEntity
    With ThisDrawing.ModelSpace
        Select Case .Count
            Case 0
                MsgBox "图纸上还木有画直线呢亲！"
            Case Is > 0
                For Each LineObject In ThisDrawing.ModelSpace
                    LineObject.Highlight False
                Next
        End Select
    End With
End Sub
Sub GetColorSelected() '直线颜色的改变
    Select Case LstColors.ListIndex
        Case 0
            CurrentDrawingColor = vbBlack
        Case 1
            CurrentDrawingColor = acRed
        Case 2
            CurrentDrawingColor = acYellow
        Case 3
            CurrentDrawingColor = acGreen
        Case 4
            CurrentDrawingColor = acCyan
        Case 5
            CurrentDrawingColor = acBlue
        Case 6
            CurrentDrawingColor = acMagenta
        Case Else
            CurrentDrawingColor = acWhite
    End Select
End Sub
Sub GetUsersSelection()
    Dim UsersSelection As AcadSelectionSet, DrawingSelected As AcadEntity
    'delete the selection set if it already exists,取消选择，如果他已经被选中
    With ThisDrawing
        On Error Resume Next
        .SelectionSets("CurrentSelection").Delete
        'get selection from user 从用户窗口获得选择集
        ThisDrawing.Utility.Prompt vbLf & "请选择对象，点击回车确认！" & vbLf
        Set UsersSelection = .SelectionSets.Add("CurrentSelection")
        UsersSelection.SelectOnScreen
        For Each DrawingSelected In UsersSelection
            DrawingSelected.color = acGreen
        Next
        .ModelSpace.Item(.ModelSpace.Count - 1).Update
    End With
    Me.Show
End Sub

Private Sub ChkLstColor_Click()
    With ChkLstColor
        If .Value = True Then
            LstColors.Visible = True
        Else
            LstColors.Visible = False
        End If
    End With
End Sub

Private Sub CmdCancel_Click()
End
End Sub

Private Sub CmdOK_Click()
If LstTypes.ListIndex > -1 Then
    ThisDrawing.ActiveLinetype = ThisDrawing.LineTypes(LstTypes.List(LstTypes.ListIndex))
End If
'Unload Me
End Sub

Private Sub CommandButton1_Click()
    Unload Me
    MY000_Contents.Show
End Sub

Private Sub CommandButton2_Click() '创建一条直线按钮
If IsNumeric(TxtStartPointX.Text) And IsNumeric(TxtStartPointY.Text) And IsNumeric(TxtStartPointZ.Text) And IsNumeric(TxtEndPointX.Text) And IsNumeric(TxtEndPointY.Text) And IsNumeric(TxtEndPointZ.Text) = True Then
    CreateLine
    With ThisDrawing.ModelSpace
        .Item(.Count - 1).Update
    End With
Else
    MsgBox "请全部填写数字坐标！"
End If

End Sub

Private Sub CommandButton3_Click() '直线高亮操作
    Dim MyPoint(2) As Double, CurrentDrawingColor As Integer
    MyPoint(0) = 0
    MyPoint(1) = 0
    MyPoint(2) = 0
    'MsgBox "ChkHighLightLast.value:" & ChkHighLightLast.Value & vbLf & "ChkHighLightAllItems.value:" & ChkHighLightAllItems.Value
    If ChkHighLightLast.Value = True And ChkHighLightAllItems.Value = True Then  '高亮显示
           
            HighLightAllItems
            ThisDrawing.Utility.Prompt vbLf & "全部直线高亮显示" & vbLf
    ElseIf ChkHighLightLast.Value = True And ChkHighLightAllItems.Value = False Then
            HighLightLastItemDrawn
            ThisDrawing.Utility.Prompt vbLf & "最后一条直线高亮显示" & vbLf
    ElseIf ChkHighLightLast.Value = False And ChkHighLightAllItems.Value = True Then '不高亮显示
            UnHighLightAllItems
            ThisDrawing.Utility.Prompt vbLf & "所有直线取消高亮显示" & vbLf
    Else
            UnHighLightLastItemDrawn
            ThisDrawing.Utility.Prompt vbLf & "最后一条直线取消高亮显示" & vbLf
    End If
'为了让效果可以实时地看到，我们在程序最后通过创建一个辅助点Point1，并对Point1进行update，然后删除这个辅助点。程序如下。
    With ThisDrawing.ModelSpace
        .AddPoint MyPoint
        .Item(.Count - 1).Update '通过载入这个点，来显示那些之前创建的对象的加亮效果。
        .Item(.Count - 1).Delete '改点的作用已经达到那么删除该点，有点过河拆桥的意思。
    End With
End Sub

Private Sub ComGetUsersSelection_Click()
Me.Hide
GetUsersSelection
End Sub

Private Sub Frame2_Click()

End Sub

Private Sub LstColors_Click()
    Dim CurrentObject As AcadLine
    With ThisDrawing.ModelSpace
        Select Case .Count
            Case 0
                MsgBox "你还没画东东呢改什么颜色！你说呢是不是傻！是不是傻！"
            Case Is > 0
                GetColorSelected
                If ChkHighLightAllItems.Value = True Then
                    For Each CurrentObject In ThisDrawing.ModelSpace
                        CurrentObject.color = CurrentDrawingColor
                        CurrentObject.Update
                    Next
                    ThisDrawing.Utility.Prompt vbLf & "所有直线颜色已经改好" & vbLf
                Else
                   
                    .Item(.Count - 1).color = CurrentDrawingColor
                    .Item(.Count - 1).Update
                    ThisDrawing.Utility.Prompt vbLf & "最后一条直线颜色已经改好" & vbLf
                End If
        End Select
    End With
    'MsgBox CurrentDrawingColor
End Sub

Private Sub LstTypes_Click()

End Sub

Private Sub UserForm_Initialize() 'CAD窗口初始化的时候进行的预操作。
    Dim CurrentLineType As AcadLineType
    For Each CurrentLineType In ThisDrawing.LineTypes
        LstTypes.AddItem CurrentLineType.name
        If CurrentLineType.name = ThisDrawing.ActiveLinetype.name Then
            LstTypes.Selected(LstTypes.ListCount - 1) = True
        End If
    Next
    With LstColors
        .Visible = False
        .AddItem "黑色Black"
        .AddItem "红色Red"
        .AddItem "黄色Yellow"
        .AddItem "绿色Green"
        .AddItem "青色Cyan"
        .AddItem "蓝色Blue"
        .AddItem "紫色Magenta"
        .AddItem "白色White"
    End With
End Sub