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 ...
随机推荐
- jQuery实用的语法总结
1.关于页面元素的引用 通过jquery的$()引用元素包括通过id.class.元素名以及元素的层级关系及dom或者xpath条件等方法,且返回的对象为jquery对象(集合对象),不能直接调用do ...
- JS数组添加字典的方法
var ary_RoleType = []; //申明数组变量 for(var j = 0;j<treeData.length;j++){ if($.inArray(treeData[j].v ...
- 孙鑫MFC学习笔记5:文本显示
1.CreateSolidCaret添加一个插入符 参数:宽度,高度 如果设为0,就设为默认窗口边界的宽度和高度 2.GetSystemMetrics获取默认窗口边界的宽度和高度 3.Caret在创建 ...
- SSH实例(4)
Clas.hbm.xml文件如下: <?xml version="1.0" encoding="utf-8"?> <!DOCTYPE hibe ...
- SQL简单语句总结习题
创建一个表记员工个人信息: --创建一个表 create table plspl_company_info( empno ) not null, ename ) not null, job ), ma ...
- Scalaz(11)- Monad:你存在的意义
前面提到了scalaz是个函数式编程(FP)工具库.它提供了许多新的数据类型.拓展的标准类型及完整的一套typeclass来支持scala语言的函数式编程模式.我们知道:对于任何类型,我们只需要实现这 ...
- CnBlogs自定义博客样式
弄了半个晚上的时间,总算马马虎虎搞好了博客的样式. 整个博客是蓝色的基调,比较激情,我喜欢. 比较郁闷的是,rightmenu 和 main都是position:absolute 布局的.要添加一个f ...
- GJM : Python简单爬虫入门 (一) [转载]
版权声明:本文原创发表于 [请点击连接前往] ,未经作者同意必须保留此段声明!如有侵权请联系我删帖处理! 为大家介绍一个简单的爬虫工具BeautifulSoup BeautifulSoup拥有强大的解 ...
- Linux IO函数的使用和区别
Linux系统中的IO函数主要有read.write.recv.send.recvmsg.sendmsg.readv.writev,本篇主要介绍他们的使用以及区别. read函数: #include ...
- 精通 CSS 选择器(二)
补充了一些之前遗漏掉的选择器以及一些在 Selectors Level 4 中新定义的选择器. 属性选择器不区分大小写 [attribute="value" i],在 Select ...