Sub TestShowCommand()ShowCommand "畫條線"ShowPrompt "選擇第一個點"ShowStatus "選擇第二個點"End SubSub TestShowTempMessage()ShowTempMessage msdStatusBarAreaLeft, "消息左側"ShowTempMessage msdStatusBarAreaMiddle, "消息中部"End SubSub TestShowTempMessageCenter()ShowTempMessage msdStatusBarAreaMiddle, "修改文件：", "奔跑吧兄弟"End SubSub TestShowError()ShowError "Selection of Cell Failed"End SubSub TestSelectionSetA()Dim myElement As ElementDim myElemEnum As ElementEnumeratorSet myElemEnum = ActiveModelReference.GetSelectedElementsWhile myElemEnum.MoveNextSet myElement = myElemEnum.CurrentmyElement.Level = ActiveModelReference.Levels("Default")myElement.RewriteWendEnd SubSub TestSelectionSetC()Dim mySettings As SettingsSet mySettings = Application.ActiveSettingsIf MsgBox("Change Selection to Color " & mySettings.Color & "?", vbYesNo) = vbYes ThenDim myElement As ElementDim myElemEnum As ElementEnumeratorSet myElemEnum = ActiveModelReference.GetSelectedElementsWhile myElemEnum.MoveNextSet myElement = myElemEnum.CurrentmyElement.Color = mySettings.ColormyElement.RewriteWendEnd IfEnd Sub

?

Sub TestCadInputA()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim I As LongSet myCIQ = CadInputQueueFor I = 1 To 10Set myCIM = myCIQ.GetInputDebug.Print myCIM.InputTypeNext IEnd Sub

?

Sub TestCadInputB()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim I As LongDim pt3Selection As Point3dSet myCIQ = CadInputQueueFor I = 1 To 10Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint)pt3Selection = myCIM.pointDebug.Print pt3Selection.X & ", " & pt3Selection.YNext IEnd Sub

?

Sub TestCadInputC()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim I As LongDim pt3Selection As Point3dSet myCIQ = CadInputQueueFor I = 1 To 10Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeDataPointpt3Selection = myCIM.pointDebug.Print pt3Selection.X & ", "; pt3Selection.YCase msdCadInputTypeResetExit ForEnd SelectNext IEnd Sub

?

Sub TestCadInputD()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim I As LongDim pt3Selection As Point3dSet myCIQ = CadInputQueueFor I = 1 To 10Set myCIM = myCIQ.GetInputSelect Case myCIM.InputTypeCase msdCadInputTypeCommandDebug.Print "Command" & vbTab & myCIM.CommandKeyinCase msdCadInputTypeResetExit ForCase msdCadInputTypeResetpt3Selection = myCIM.pointDebug.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.ZCase msdCadInputTypeKeyinDebug.Print "Keyin" & vbTab & myCIM.KeyinCase msdCadInputTypeAnyDebug.Print "Any"Case msdCadInputTypeUnassignedCBDebug.Print "UnassignedCB" & vbTab & myCIM.CursorButtonEnd SelectNext IEnd Sub

?

Sub TestCadInputF()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim StPt As Point3dDim EnPt As Point3dDim myLine As LineElementSet myCIQ = CadInputQueueShowCommand "Two-Point Line"ShowPrompt "Select First Point"Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetShowPrompt ""ShowCommand ""ShowStatus "Two-Point Line Reset"Exit SubCase msdCadInputTypeDataPointStPt = myCIM.pointEnd SelectShowPrompt "Select Second Point:"Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetShowPrompt ""ShowCommand ""ShowStatus "Two-Point Line Reset"Exit SubCase msdCadInputTypeDataPointEnPt = myCIM.pointEnd SelectSet myLine = CreateLineElement2(Nothing, StPt, EnPt)ActiveModelReference.AddElement myLinemyLine.RedrawShowPrompt ""ShowCommand ""ShowStatus "Two-Point Line Drawn"End Sub

?

Sub TestCadInputH()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim StPt As Point3dDim EnPt As Point3dDim myLine As LineElementDim SelElems() As ElementSet myCIQ = CadInputQueueSet myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetExit SubCase msdCadInputTypeDataPointStPt = myCIM.pointEnd SelectSet myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetExit SubCase msdCadInputTypeDataPointEnPt = myCIM.pointEnd SelectCadInputQueue.SendDragPoints StPt, EnPtSelElems = ActiveModelReference.GetSelectedElements.BuildArrayFromContentsIf MsgBox("Are you sure you want to delete " & UBound(SelElems) + 1 & " Elements?", vbYesNo) = vbYes ThenCadInputQueue.SendCommand "DELETE"End IfEnd Sub

?

Function PointsByLine() As Point3d()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim pt3Start As Point3dDim pt3End As Point3dDim selPts(0 To 1) As Point3dSet myCIQ = CadInputQueueSet myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetErr.Raise -12345Exit FunctionCase msdCadInputTypeDataPointpt3Start = myCIM.pointEnd SelectCadInputQueue.SendCommand "PLACE LINE"CadInputQueue.SendDataPoint pt3StartSet myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetErr.Raise -12346Exit FunctionCase msdCadInputTypeDataPointpt3End = myCIM.pointEnd SelectselPts(0) = pt3StartselPts(1) = pt3EndPointsByLine = selPtsEnd FunctionSub TestCadInputJ()On Error GoTo errhndDim selPts() As Point3dselPts = PointsByLineCadInputQueue.SendResetCommandState.StartDefaultCommandDebug.Print selPts(0).X & ", " & selPts(0).Y & ", " & selPts(0).ZDebug.Print selPts(1).X & ", " & selPts(1).Y & ", " & selPts(1).ZExit Suberrhnd:CadInputQueue.SendResetCommandState.StartDefaultCommandSelect Case Err.NumberCase -12345'未選擇起始點MsgBox "Start Point not selected.", vbCriticalCase -12346'未選擇終止點MsgBox "End Point not selected.", vbCriticalEnd SelectEnd Sub

?

Sub TestCadInputK()On Error GoTo errhndDim selPts() As Point3dDim pt3TextPt As Point3dDim myText As TextElementDim rotMatrix As Matrix3dselPts = PointsByLineCadInputQueue.SendResetCommandState.StartDefaultCommandSet myText = CreateTextElement1(Nothing, "Start", selPts(0), rotMatrix)ActiveModelReference.AddElement myTextSet myText = CreateTextElement1(Nothing, "End", selPts(1), rotMatrix)ActiveModelReference.AddElement myTextpt3TextPt.X = selPts(0).X + (selPts(1).X - selPts(0).X) / 2pt3TextPt.Y = selPts(0).Y + (selPts(1).Y - selPts(0).Y) / 2pt3TextPt.Z = selPts(0).Z + (selPts(1).Z - selPts(0).Z) / 2Set myText = CreateTextElement1(Nothing, "Mid", pt3TextPt, rotMatrix)ActiveModelReference.AddElement myTextExit Suberrhnd:CadInputQueue.SendResetCommandState.StartDefaultCommandSelect Case Err.NumberCase -12345'未選擇起始點MsgBox "Start Point not selected.", vbCriticalCase -12346'未選擇終止點MsgBox "End Point not selected.", vbCriticalEnd SelectEnd Sub

?

Function PointsByRectangle() As Point3d()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim pt3Start As Point3dDim pt3End As Point3dDim selPts(0 To 1) As Point3dSet myCIQ = CadInputQueueSet myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetErr.Raise -12345Exit FunctionCase msdCadInputTypeDataPointpt3Start = myCIM.pointEnd SelectCadInputQueue.SendCommand "PLACE BLOCK"CadInputQueue.SendDataPoint pt3StartSet myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset)Select Case myCIM.InputTypeCase msdCadInputTypeResetErr.Raise -12346Exit FunctionCase msdCadInputTypeDataPointpt3End = myCIM.pointEnd SelectselPts(0) = pt3StartselPts(1) = pt3EndPointByRectangle = selPtsEnd FunctionSub TestCadInputL()On Error GoTo errhndDim selPts() As Point3dselPts = PointsByRectangleCadInputQueue.SendResetCommandState.StartDefaultCommandDebug.Print selPts(0).X & ", " & selPts(0).Y & ", " & selPts(0).ZDebug.Print selPts(1).X & ", " & selPts(1).Y & ", " & selPts(1).ZExit Suberrhnd:CadInputQueue.SendResetCommandState.StartDefaultCommandSelect Case Err.NumberCase -12345'未選擇起始點MsgBox "Start Point not selected.", vbCriticalCase -12346'未選擇終止點MsgBox "End Point not selected.", vbCriticalEnd SelectEnd Sub

?

Sub TestCadInputM()On Error GoTo errhndDim selPts() As Point3dDim LinePts(0 To 1) As Point3dDim LineElem As LineElementDim myESC As New ElementScanCriteriaDim myRange As Range3dDim myElemEnum As ElementEnumeratorDim myElem As ElementDim FFile As LongDim myCellHeader As CellElementselPts = PointsByRectangleCadInputQueue.SendResetCommandState.StartDefaultCommandmyRange = Range3dFromPoint3dPoint3d(selPts(0), selPts(1))myESC.ExcludeAllTypesmyESC.IncludeType msdElementTypeCellHeadermyESC.IncludeOnlyWithinRange myRangeSet myElemEnum = ActiveModelReference.Scan(myESC)FFile = FreeFileOpen "C:\MicroStation VBA\CellExport.txt" For Output As #FFilePrint #FFile, ActiveDesignFile.NameWhile myElemEnum.MoveNextSet myElem = myElemEnum.CurrentSet myCellHeader = myElemPrint #FFile, myCellHeader.Name & vbTab & myCellHeader.Origin.X & _myCellHeader.Origin.Y & vbTab & myCellHeader.Origin.ZWendClose #FFileExit Suberrhnd:CadInputQueue.SendResetCommandState.StartDefaultCommandSelect Case Err.NumberCase -12345'未選擇起始點MsgBox "Start Point not selected.", vbCriticalCase -12346'未選擇終止點MsgBox "End Point not selected.", vbCriticalEnd SelectEnd Sub

?

Sub Macro1()Dim startPoint As Point3dDim point As Point3d, point2 As Point3dDim logTemp As Long'啟動一條命令 CadInputQueue.SendCommand "CGPLACE LINE CONSTRANED"'以主單位表示的坐標 startPoint.X = 16735.231975startPoint.Y = 22030.733029startPoint.Z = 0#'給當前命令發送一個數據點 point.X = startPoint.Xpoint.Y = startPoint.Ypoint.Z = startPoint.ZCadInputQueue.SendDataPoint point, 1point.X = startPoint.X + 1985.401024point.Y = startPoint.Y - 610.892623point.Z = startPoint.ZCadInputQueue.SendDataPoint point, 1'給當前命令發送一個復位 CadInputQueue.SendResetCommandState.StartDefaultCommandEnd SubSub Macro1_modifiedA()Dim point As Point3dCadInputQueue.SendCommand "CGPLACE LINE CONSTRINED"point.X = 0: point.Y = 0: point.Z = 0CadInputQueue.SendDataPoint point, 1point.X = 4: point.Y = 5: point.Z = 6CadInputQueue.SendDataPoint point, 1CadInputQueue.SendResetCommandState.StartDefaultCommandEnd SubSub Macro2_modifiedA()Dim point As Point3dCadInputQueue.SendCommand "PLACE BLOCK ICON"point.X = 0: point.Y = 0: point.Z = 0CadInputQueue.SendDataPoint point, 1point.X = point.X + 2.5point.Y = point.Y - 0.75CadInputQueue.SendDataPoint point, 1CommandState.StartDefaultCommandEnd SubSub TestCadInput()Dim myCIQ As CadInputQueueDim myCIM As CadInputMessageDim I As LongSet myCIQ = CadInputQueueFor I = 1 To 10Set myCIM = myCIQ.GetInput(msdCadInputTypeCommand)Debug.Print myCIM.CommandKeyinNext IEnd Sub

?

Option ExplicitDim elemSource As ElementPrivate Sub bstSelectSource_Click()Dim myElements() As ElementDim myElemEnum As ElementEnumeratorDim myColorTable As ColorTableSet myElemEnum = ActiveModelReference.GetSelectedElementsmyElements = ActiveModelReference.GetSelectedElements.BuildArrayFromContentsIf UBound(myElements) = 0 ThenSet elemSource = myElements(0)If Not myElements(0).Level Is Nothing ThentxtLevel.Text = myElements(0).Level.NameEnd IfSet myColorTable = ActiveDesignFile.ExtractColorTableSelect Case myElements(0).ColorCase -1txtColor.Text = ""txtColor.BackColor = RGB(255, 255, 255)txtLinestyle.Text = myElements(0).LineStyle.NametxtLineweight.Text = myElements(0).LineWeightCase ElsetxtColor.Text = myElements(0).ColortxtColor.BackColor = myColorTable.GetColorAtIndex(myElements(0).Color)txtLinestyle.Text = myElements(0).LineStyle.NametxtLineweight.Text = myElements(0).LineWeightEnd SelectElseSelect Case UBound(myElements)Case -1MsgBox "No ""Source"" element selected.", vbCritical, Me.CaptionExit SubCase ElseMsgBox "Only one element can be the ""Source"" " & "element.", vbCritical, Me.CaptionExit SubEnd SelectEnd IfEnd SubPrivate 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 SubPrivate Sub btnChange_Click()Dim myElements() As ElementDim myElemEnum As ElementEnumeratorDim I As LongDim boolElemModified As BooleanDim lngModCount As LonglblCount.Caption = "0 Element(s) modified."ShowStatus "0 Element(s) modified."Set myElemEnum = ActiveModelReference.GetSelectedElementsmyElements = myElemEnum.BuildArrayFromContentslngModCount = 0For I = LBound(myElements) To UBound(myElements)boolElemModified = FalseIf chkLevel.Value = True ThenmyElements(I).Level = elemSource.LevelboolElemModified = TrueEnd IfIf chkColor.Value = True ThenmyElements(I).Color = elemSource.ColorboolElemModified = TrueEnd IfIf chkLinestyle.Value = True ThenmyElements(I).LineStyle = elemSource.LineStyleboolElemModified = TrueEnd IfIf chkLineweight.Value = True ThenmyElements(I).LineWeight = elemSource.LineWeightboolElemModified = TrueEnd IfIf boolElemModified = True ThenmyElements(I).RewritelngModCount = lngModCount + 1End IfNext IlblCount.Caption = lngModCount & " Element(s) modified."ShowStatus lngModCount & " Element(s) modified."End SubPrivate Sub btnChange_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)ShowPrompt "Select ""Destination"" Elements:"End SubPrivate Sub btnClose_Click()Unload MeEnd SubPrivate 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 SubPrivate Sub fraDestination_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)ShowPrompt ""End SubPrivate Sub fraSource_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)ShowPrompt ""End SubPrivate Sub UserForm_Initialize()ShowCommand "VBA MAtch Properties:"End SubPrivate Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)ShowPrompt ""End SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)ShowPrompt ""ShowCommand ""End SubSub TestMatchProperties()frmMatchProperties.Show vbModelessEnd Sub

?

轉載于:https://www.cnblogs.com/zpfbuaa/p/5748921.html

總結

以上是生活随笔為你收集整理的MicroStation VBA 操作提示的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。