MicroStation VBA 操作提示
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 = To 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 = To 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 = To 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 = To 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) + & " 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( To ) As Point3d Set myCIQ = CadInputQueue Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Err.Raise - 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 - Exit Function Case msdCadInputTypeDataPoint pt3End = myCIM.point End Select selPts() = pt3Start selPts() = pt3End PointsByLine = selPts End Function Sub TestCadInputJ() On Error GoTo errhnd Dim selPts() As Point3d selPts = PointsByLine CadInputQueue.SendReset CommandState.StartDefaultCommand Debug.Print selPts().X & ", " & selPts().Y & ", " & selPts().Z Debug.Print selPts().X & ", " & selPts().Y & ", " & selPts().Z Exit Sub errhnd: CadInputQueue.SendReset CommandState.StartDefaultCommand Select Case Err.Number Case - '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case - '未选择终止点 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(), rotMatrix) ActiveModelReference.AddElement myText Set myText = CreateTextElement1(Nothing, "End", selPts(), rotMatrix) ActiveModelReference.AddElement myText pt3TextPt.X = selPts().X + (selPts().X - selPts().X) / pt3TextPt.Y = selPts().Y + (selPts().Y - selPts().Y) / pt3TextPt.Z = selPts().Z + (selPts().Z - selPts().Z) / Set myText = CreateTextElement1(Nothing, "Mid", pt3TextPt, rotMatrix) ActiveModelReference.AddElement myText Exit Sub errhnd: CadInputQueue.SendReset CommandState.StartDefaultCommand Select Case Err.Number Case - '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case - '未选择终止点 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( To ) As Point3d Set myCIQ = CadInputQueue Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset Err.Raise - 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 - Exit Function Case msdCadInputTypeDataPoint pt3End = myCIM.point End Select selPts() = pt3Start selPts() = pt3End PointByRectangle = selPts End Function Sub TestCadInputL() On Error GoTo errhnd Dim selPts() As Point3d selPts = PointsByRectangle CadInputQueue.SendReset CommandState.StartDefaultCommand Debug.Print selPts().X & ", " & selPts().Y & ", " & selPts().Z Debug.Print selPts().X & ", " & selPts().Y & ", " & selPts().Z Exit Sub errhnd: CadInputQueue.SendReset CommandState.StartDefaultCommand Select Case Err.Number Case - '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case - '未选择终止点 MsgBox "End Point not selected.", vbCritical End Select End Sub
Sub TestCadInputM() On Error GoTo errhnd Dim selPts() As Point3d Dim LinePts( To ) 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(), selPts()) myESC.ExcludeAllTypes myESC.IncludeType msdElementTypeCellHeader myESC.IncludeOnlyWithinRange myRange Set myElemEnum = ActiveModelReference.Scan(myESC) FFile = FreeFile Open "C:\MicroStation VBA\CellExport.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 - '未选择起始点 MsgBox "Start Point not selected.", vbCritical Case - '未选择终止点 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 = # '给当前命令发送一个数据点 point.X = startPoint.X point.Y = startPoint.Y point.Z = startPoint.Z CadInputQueue.SendDataPoint point, point.X = startPoint.X + 1985.401024 point.Y = startPoint.Y - 610.892623 point.Z = startPoint.Z CadInputQueue.SendDataPoint point, '给当前命令发送一个复位 CadInputQueue.SendReset CommandState.StartDefaultCommand End Sub Sub Macro1_modifiedA() Dim point As Point3d CadInputQueue.SendCommand "CGPLACE LINE CONSTRINED" point.X = : point.Y = : point.Z = CadInputQueue.SendDataPoint point, point.X = : point.Y = : point.Z = CadInputQueue.SendDataPoint point, CadInputQueue.SendReset CommandState.StartDefaultCommand End Sub Sub Macro2_modifiedA() Dim point As Point3d CadInputQueue.SendCommand "PLACE BLOCK ICON" point.X = : point.Y = : point.Z = CadInputQueue.SendDataPoint point, point.X = point.X + 2.5 point.Y = point.Y - 0.75 CadInputQueue.SendDataPoint point, CommandState.StartDefaultCommand End Sub Sub TestCadInput() Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim I As Long Set myCIQ = CadInputQueue For I = To 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) = Then Set elemSource = myElements() If Not myElements().Level Is Nothing Then txtLevel.Text = myElements().Level.Name End If Set myColorTable = ActiveDesignFile.ExtractColorTable Select Case myElements().Color Case - txtColor.Text = "" txtColor.BackColor = RGB(, , ) txtLinestyle.Text = myElements().LineStyle.Name txtLineweight.Text = myElements().LineWeight Case Else txtColor.Text = myElements().Color txtColor.BackColor = myColorTable.GetColorAtIndex(myElements().Color) txtLinestyle.Text = myElements().LineStyle.Name txtLineweight.Text = myElements().LineWeight End Select Else Select Case UBound(myElements) Case - 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 = 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 + 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
MicroStation VBA 操作提示的更多相关文章
- VBA 操作数字
第8章 操作数字 加.减.乘.除.平方与指数(^2 或者^n).平方根Sqr.正弦Sin.余弦Cos.正切Tan.反正切Atn.绝对值Abs 转换为整型数.长整型数.双精度型数和值 Cint当双精度型 ...
- MicroStation VBA基础
实习笔记1 2016年8月1日 14:12 Option Explicit 缺省情况下,如果使用一个没有声明的变量,它将继承“Variant”类型.在模块.窗体和类的通用声明区使用“OptionExp ...
- Excel VBA 操作 Word(入门篇)
原文地址 本文的对象是:有一定Excel VBA基础,对Word VBA还没有什么认识,想在Excel中通过VBA操作Word还有困难的人. 一.新建Word引用 需要首先创建一个对 Word A ...
- 小技巧:SystemTray中进行操作提示
SystemTray中进行操作提示在wp中应用比较广泛,截图如下. 实现方法也十分简单 1.xaml代码中写入: shell:SystemTray.IsVisible="True" ...
- AIX-vi操作-提示Unknown terminal type的问题解决方法
AIX-vi操作-提示Unknown terminal type的问题解决方法AIX Version 5.3$ vi /etc/profilelinux: Unknown terminal type[ ...
- wp8.1 app退出操作提示
微软的wp8.1 sdk相比之前wp8 sdk以及相关dll类库,微软又重新编译过,相关系统类库也经过精简,删改了部分传统dll库中的方法对象,很多常用方法对象被写进Windows.UI为前缀的命名空 ...
- eclipse的hadoop插件对集群操作提示org.apache.hadoop.security.AccessControlException:Permission denied
eclipse的hadoop插件对集群操作提示org.apache.hadoop.security.AccessControlException:Permission denied: user = z ...
- Android使用ShowcaseView加入半透明操作提示图片的方法
http://beeder.me/2014/11/11/how-to-add-a-semi-transparent-demo-screen-using-showcaseview/ 这篇文章具体介绍了如 ...
- flutter Tooltip轻量级操作提示
Tooltip是继承于StatefulWidget的一个Widget,它并不需要调出方法,当用户长按被Tooltip包裹的Widget时,会自动弹出相应的操作提示. import 'package:f ...
随机推荐
- WinForm GDI+ 资料收集
UI(User Interface)编程在整个项目开发过程中是个颇为重要的环节,任何好的解决方案若没有良好的用户界面呈现给最终用户,那么就算包含了最先进的技术也不能算是好程序.UI编程体现在两个方面, ...
- jquery Ajax异步请求之session
写了一个脚本,如下: $(function () { $("#btnVcode").click(function () { var receiveMobile = $(" ...
- 使用KeleyiSQLHelper类进行分页查询
本文适用于sql server单主键表或者视图进行分页查询,支持多字段排序. KeleyiSQLHelper类的最新代码请到http://hovertree.com/down/下载整个解决方案源代码查 ...
- 【SQL】小心字符串拼接导致长度爆表
请看代码: DECLARE @max VARCHAR(max) SET @max='aaa...' --这里有8000个a +'bb' --连接一个varchar常量或变量 SELECT LEN(@m ...
- c#通过oledb获取excel文件表结构信息
这个问题来自论坛提问,同理可以获得access等数据库的表结构信息. using System; namespace ConsoleApplication11 { class Program { pu ...
- Javascript权威指南
一.数字写法 3.14 2345.789 .333333333333333333 6.02e23 // 6.02 × 10 23 1.4738223E-32 // 1.4738223 × 10 −32 ...
- Java/Android引用类型及其使用分析
Java/Android中有四种引用类型,分别是: Strong reference - 强引用Soft Reference - 软引用Weak Reference - ...
- Java面试题系列 提高Java I/O 性能
1.提高java的 i/o性能.. http://blog.csdn.net/cherami/article/details/3854 我们知道Java中一般的输入输出流都是用单字节的读取方法来进行I ...
- 《Java4Android》视频学习笔记——包和访问权限(一)
怎么打包?代码如下 package org.marsdroid; class Test{ public static void main(String args[]){ System.out.prin ...
- go语言常用函数:cap
cap()函数返回的是数组切片分配的空间大小.//http://www.cnblogs.com/osfipin/. package main import "fmt" func m ...