'如果需要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