Sub TestShowCommand() ShowCommand "画条线" ShowPrompt "选择第一个点" ShowStatus "选择第二个点" End Sub Sub TestShowTempMessage() ShowTempMessage msdStatusBarAreaLeft, "消息左侧" ShowTempMessage msdStatusBarAreaMiddle, "消息中部" End Sub Sub TestShowTempMessageCenter() ShowTempMessage msdStatusBarAreaMiddle, "修改文件：", "奔跑吧兄弟" End Sub Sub TestShowError() ShowError "Selection of Cell Failed" End Sub Sub TestSelectionSetA() Dim myElement As Element Dim myElemEnum As ElementEnumerator Set myElemEnum = ActiveModelReference.GetSelectedElements While myElemEnum.MoveNext Set myElement = myElemEnum.Current myElement.Level = ActiveModelReference.Levels("Default") myElement.Rewrite Wend End Sub Sub TestSelectionSetC() Dim mySettings As Settings Set mySettings = Application.ActiveSettings If MsgBox("Change Selection to Color " & mySettings.Color & "?", vbYesNo) = vbYes Then Dim myElement As Element Dim myElemEnum As ElementEnumerator Set myElemEnum = ActiveModelReference.GetSelectedElements While myElemEnum.MoveNext Set myElement = myElemEnum.Current myElement.Color = mySettings.Color myElement.Rewrite Wend End If End Sub
Sub TestCadInputA() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim I As Long Set myCIQ = CadInputQueue For I = 1 To 10 Set myCIM = myCIQ.GetInput Debug.Print myCIM.InputType Next I End Sub
Sub TestCadInputB() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim I As Long Dim pt3Selection As Point3d Set myCIQ = CadInputQueue For I = 1 To 10 Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint) pt3Selection = myCIM.point Debug.Print pt3Selection.X & ", " & pt3Selection.Y Next I End Sub
Sub TestCadInputC() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim I As Long Dim pt3Selection As Point3d Set myCIQ = CadInputQueue For I = 1 To 10 Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeDataPoint pt3Selection = myCIM.point Debug.Print pt3Selection.X & ", "; pt3Selection.Y Case msdCadInputTypeReset Exit For End Select Next I End Sub
Sub TestCadInputD() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim I As Long Dim pt3Selection As Point3d Set myCIQ = CadInputQueue For I = 1 To 10 Set myCIM = myCIQ.GetInput Select Case myCIM.InputType Case msdCadInputTypeCommand Debug.Print "Command" & vbTab & myCIM.CommandKeyin Case msdCadInputTypeReset Exit For Case msdCadInputTypeReset pt3Selection = myCIM.point Debug.Print "Point" & vbTab & pt3Selection.X & vbTab & pt3Selection.Y & vbTab & _ pt3Selection.Z & vbTab & myCIM.View.Index & vbTab & myCIM.ScreenPoint.X & _ vbTab & myCIM.ScreenPoint.Y & vbTab & myCIM.ScreenPoint.Z Case msdCadInputTypeKeyin Debug.Print "Keyin" & vbTab & myCIM.Keyin Case msdCadInputTypeAny Debug.Print "Any" Case msdCadInputTypeUnassignedCB Debug.Print "UnassignedCB" & vbTab & myCIM.CursorButton End Select Next I End Sub
Sub TestCadInputF() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim StPt As Point3d Dim EnPt As Point3d Dim myLine As LineElement Set myCIQ = CadInputQueue ShowCommand "Two-Point Line" ShowPrompt "Select First Point" Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset ShowPrompt "" ShowCommand "" ShowStatus "Two-Point Line Reset" Exit Sub Case msdCadInputTypeDataPoint StPt = myCIM.point End Select ShowPrompt "Select Second Point:" Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset ShowPrompt "" ShowCommand "" ShowStatus "Two-Point Line Reset" Exit Sub Case msdCadInputTypeDataPoint EnPt = myCIM.point End Select Set myLine = CreateLineElement2(Nothing, StPt, EnPt) ActiveModelReference.AddElement myLine myLine.Redraw ShowPrompt "" ShowCommand "" ShowStatus "Two-Point Line Drawn" End Sub
Sub TestCadInputH() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim StPt As Point3d Dim EnPt As Point3d Dim myLine As LineElement Dim SelElems() As Element Set myCIQ = CadInputQueue Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Exit Sub Case msdCadInputTypeDataPoint StPt = myCIM.point End Select Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Exit Sub Case msdCadInputTypeDataPoint EnPt = myCIM.point End Select CadInputQueue.SendDragPoints StPt, EnPt SelElems = ActiveModelReference.GetSelectedElements.BuildArrayFromContents If MsgBox("Are you sure you want to delete " & UBound(SelElems) + 1 & " Elements?", vbYesNo) = vbYes Then CadInputQueue.SendCommand "DELETE" End If End Sub
Function PointsByLine() As Point3d() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim pt3Start As Point3d Dim pt3End As Point3d Dim selPts(0 To 1) As Point3d Set myCIQ = CadInputQueue Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Err.Raise -12345 Exit Function Case msdCadInputTypeDataPoint pt3Start = myCIM.point End Select CadInputQueue.SendCommand "PLACE LINE" CadInputQueue.SendDataPoint pt3Start Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Err.Raise -12346 Exit Function Case msdCadInputTypeDataPoint pt3End = myCIM.point End Select selPts(0) = pt3Start selPts(1) = pt3End PointsByLine = selPts End Function Sub TestCadInputJ() On Error GoTo errhnd Dim selPts() As Point3d selPts = PointsByLine CadInputQueue.SendReset CommandState.StartDefaultCommand Debug.Print selPts(0).X & ", " & selPts(0).Y & ", " & selPts(0).Z Debug.Print selPts(1).X & ", " & selPts(1).Y & ", " & selPts(1).Z Exit Sub errhnd: CadInputQueue.SendReset CommandState.StartDefaultCommand Select Case Err.Number Case -12345 '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case -12346 '未选择终止点 MsgBox "End Point not selected.", vbCritical End Select End Sub
Sub TestCadInputK() On Error GoTo errhnd Dim selPts() As Point3d Dim pt3TextPt As Point3d Dim myText As TextElement Dim rotMatrix As Matrix3d selPts = PointsByLine CadInputQueue.SendReset CommandState.StartDefaultCommand Set myText = CreateTextElement1(Nothing, "Start", selPts(0), rotMatrix) ActiveModelReference.AddElement myText Set myText = CreateTextElement1(Nothing, "End", selPts(1), rotMatrix) ActiveModelReference.AddElement myText pt3TextPt.X = selPts(0).X + (selPts(1).X - selPts(0).X) / 2 pt3TextPt.Y = selPts(0).Y + (selPts(1).Y - selPts(0).Y) / 2 pt3TextPt.Z = selPts(0).Z + (selPts(1).Z - selPts(0).Z) / 2 Set myText = CreateTextElement1(Nothing, "Mid", pt3TextPt, rotMatrix) ActiveModelReference.AddElement myText Exit Sub errhnd: CadInputQueue.SendReset CommandState.StartDefaultCommand Select Case Err.Number Case -12345 '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case -12346 '未选择终止点 MsgBox "End Point not selected.", vbCritical End Select End Sub
Function PointsByRectangle() As Point3d() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim pt3Start As Point3d Dim pt3End As Point3d Dim selPts(0 To 1) As Point3d Set myCIQ = CadInputQueue Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Err.Raise -12345 Exit Function Case msdCadInputTypeDataPoint pt3Start = myCIM.point End Select CadInputQueue.SendCommand "PLACE BLOCK" CadInputQueue.SendDataPoint pt3Start Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Err.Raise -12346 Exit Function Case msdCadInputTypeDataPoint pt3End = myCIM.point End Select selPts(0) = pt3Start selPts(1) = pt3End PointByRectangle = selPts End Function Sub TestCadInputL() On Error GoTo errhnd Dim selPts() As Point3d selPts = PointsByRectangle CadInputQueue.SendReset CommandState.StartDefaultCommand Debug.Print selPts(0).X & ", " & selPts(0).Y & ", " & selPts(0).Z Debug.Print selPts(1).X & ", " & selPts(1).Y & ", " & selPts(1).Z Exit Sub errhnd: CadInputQueue.SendReset CommandState.StartDefaultCommand Select Case Err.Number Case -12345 '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case -12346 '未选择终止点 MsgBox "End Point not selected.", vbCritical End Select End Sub
Sub TestCadInputM() On Error GoTo errhnd Dim selPts() As Point3d Dim LinePts(0 To 1) As Point3d Dim LineElem As LineElement Dim myESC As New ElementScanCriteria Dim myRange As Range3d Dim myElemEnum As ElementEnumerator Dim myElem As Element Dim FFile As Long Dim myCellHeader As CellElement selPts = PointsByRectangle CadInputQueue.SendReset CommandState.StartDefaultCommand myRange = Range3dFromPoint3dPoint3d(selPts(0), selPts(1)) myESC.ExcludeAllTypes myESC.IncludeType msdElementTypeCellHeader myESC.IncludeOnlyWithinRange myRange Set myElemEnum = ActiveModelReference.Scan(myESC) FFile = FreeFile Open "C:MicroStation VBACellExport.txt" For Output As #FFile Print #FFile, ActiveDesignFile.Name While myElemEnum.MoveNext Set myElem = myElemEnum.Current Set myCellHeader = myElem Print #FFile, myCellHeader.Name & vbTab & myCellHeader.Origin.X & _ myCellHeader.Origin.Y & vbTab & myCellHeader.Origin.Z Wend Close #FFile Exit Sub errhnd: CadInputQueue.SendReset CommandState.StartDefaultCommand Select Case Err.Number Case -12345 '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case -12346 '未选择终止点 MsgBox "End Point not selected.", vbCritical End Select End Sub
Sub Macro1() Dim startPoint As Point3d Dim point As Point3d, point2 As Point3d Dim logTemp As Long '启动一条命令 CadInputQueue.SendCommand "CGPLACE LINE CONSTRANED" '以主单位表示的坐标 startPoint.X = 16735.231975 startPoint.Y = 22030.733029 startPoint.Z = 0# '给当前命令发送一个数据点 point.X = startPoint.X point.Y = startPoint.Y point.Z = startPoint.Z CadInputQueue.SendDataPoint point, 1 point.X = startPoint.X + 1985.401024 point.Y = startPoint.Y - 610.892623 point.Z = startPoint.Z CadInputQueue.SendDataPoint point, 1 '给当前命令发送一个复位 CadInputQueue.SendReset CommandState.StartDefaultCommand End Sub Sub Macro1_modifiedA() Dim point As Point3d CadInputQueue.SendCommand "CGPLACE LINE CONSTRINED" point.X = 0: point.Y = 0: point.Z = 0 CadInputQueue.SendDataPoint point, 1 point.X = 4: point.Y = 5: point.Z = 6 CadInputQueue.SendDataPoint point, 1 CadInputQueue.SendReset CommandState.StartDefaultCommand End Sub Sub Macro2_modifiedA() Dim point As Point3d CadInputQueue.SendCommand "PLACE BLOCK ICON" point.X = 0: point.Y = 0: point.Z = 0 CadInputQueue.SendDataPoint point, 1 point.X = point.X + 2.5 point.Y = point.Y - 0.75 CadInputQueue.SendDataPoint point, 1 CommandState.StartDefaultCommand End Sub Sub TestCadInput() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim I As Long Set myCIQ = CadInputQueue For I = 1 To 10 Set myCIM = myCIQ.GetInput(msdCadInputTypeCommand) Debug.Print myCIM.CommandKeyin Next I End Sub
Option Explicit Dim elemSource As Element Private Sub bstSelectSource_Click() Dim myElements() As Element Dim myElemEnum As ElementEnumerator Dim myColorTable As ColorTable Set myElemEnum = ActiveModelReference.GetSelectedElements myElements = ActiveModelReference.GetSelectedElements.BuildArrayFromContents If UBound(myElements) = 0 Then Set elemSource = myElements(0) If Not myElements(0).Level Is Nothing Then txtLevel.Text = myElements(0).Level.Name End If Set myColorTable = ActiveDesignFile.ExtractColorTable Select Case myElements(0).Color Case -1 txtColor.Text = "" txtColor.BackColor = RGB(255, 255, 255) txtLinestyle.Text = myElements(0).LineStyle.Name txtLineweight.Text = myElements(0).LineWeight Case Else txtColor.Text = myElements(0).Color txtColor.BackColor = myColorTable.GetColorAtIndex(myElements(0).Color) txtLinestyle.Text = myElements(0).LineStyle.Name txtLineweight.Text = myElements(0).LineWeight End Select Else Select Case UBound(myElements) Case -1 MsgBox "No ""Source"" element selected.", vbCritical, Me.Caption Exit Sub Case Else MsgBox "Only one element can be the ""Source"" " & "element.", vbCritical, Me.Caption Exit Sub End Select End If End Sub Private Sub bstSelectSource_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ShowPrompt "Select a single ""Source"" Element:" End Sub Private Sub btnChange_Click() Dim myElements() As Element Dim myElemEnum As ElementEnumerator Dim I As Long Dim boolElemModified As Boolean Dim lngModCount As Long lblCount.Caption = "0 Element(s) modified." ShowStatus "0 Element(s) modified." Set myElemEnum = ActiveModelReference.GetSelectedElements myElements = myElemEnum.BuildArrayFromContents lngModCount = 0 For I = LBound(myElements) To UBound(myElements) boolElemModified = False If chkLevel.Value = True Then myElements(I).Level = elemSource.Level boolElemModified = True End If If chkColor.Value = True Then myElements(I).Color = elemSource.Color boolElemModified = True End If If chkLinestyle.Value = True Then myElements(I).LineStyle = elemSource.LineStyle boolElemModified = True End If If chkLineweight.Value = True Then myElements(I).LineWeight = elemSource.LineWeight boolElemModified = True End If If boolElemModified = True Then myElements(I).Rewrite lngModCount = lngModCount + 1 End If Next I lblCount.Caption = lngModCount & " Element(s) modified." ShowStatus lngModCount & " Element(s) modified." End Sub Private Sub btnChange_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ShowPrompt "Select ""Destination"" Elements:" End Sub Private Sub btnClose_Click() Unload Me End Sub Private Sub btnClose_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ShowPrompt "Close ""VBA Match Properties""" End Sub Private Sub fraDestination_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ShowPrompt "" End Sub Private Sub fraSource_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ShowPrompt "" End Sub Private Sub UserForm_Initialize() ShowCommand "VBA MAtch Properties:" End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ShowPrompt "" End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) ShowPrompt "" ShowCommand "" End Sub Sub TestMatchProperties() frmMatchProperties.Show vbModeless End Sub
