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 = 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 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 -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

时间： 2024-10-31 12:55:35

MicroStation VBA 操作提示的相关文章

VBA 操作数字

第8章 操作数字 加.减.乘.除.平方与指数(^2 或者^n).平方根Sqr.正弦Sin.余弦Cos.正切Tan.反正切Atn.绝对值Abs 转换为整型数.长整型数.双精度型数和值 Cint当双精度型数向整型数转换时,CInt通过园整数字得到一个整型数 CLng与CInt相比:当所提供的值较大时使用CLng Fix函数只是简单地甩掉数字的小数部分,它不做任何园整.Fix能够操作整型数和长整型数 CDbl函数可将提供的参数转换为一个双精度型数 Val函数能给出参数中的数字值.Val返回所有的数字字

MicroStation VBA基础

实习笔记1 2016年8月1日 14:12 Option Explicit 缺省情况下,如果使用一个没有声明的变量,它将继承“Variant”类型.在模块.窗体和类的通用声明区使用“OptionExplicit”能强制我们必须声明变量后才能使用变量 Sample: Option Explicit Sub test() X = 5 End Sub 在通用声明区声明了“Option Explicit”.当试着去运行上述test宏时将得到一个错误 本章回顾 1.在过程.函数或用户窗体事件中写代码 2.

linux操作提示：“Can't open file for writing”或“operation not permitted”的解决办法

在linux上使用vi命令修改一个文件内容的时候,发现无法保存,每次写完使用":q!"命令可以正常退出但是使用":wq!"命令保存文件并退出时出现一下信息提示: E212: Can't open file for writing Press ENTER or type command to continue 出现这个错误的原因可能有两个:    1.当前用户的权限不足    2.此文件可能正被其他程序或用户使用.      一般错误原因都是前者,解决方案是在使用vi

AIX-vi操作-提示Unknown terminal type的问题解决方法

AIX-vi操作-提示Unknown terminal type的问题解决方法AIX Version 5.3$ vi /etc/profilelinux: Unknown terminal type[Hit return to continue] :q!I don't know what kind of terminal you are on - all I have is 'linux'.[Using open mode]……临时办法,下次启动失效,需要重新执行$ echo $TERMlinu

wp8.1 app退出操作提示

微软的wp8.1 sdk相比之前wp8 sdk以及相关dll类库,微软又重新编译过,相关系统类库也经过精简,删改了部分传统dll库中的方法对象,很多常用方法对象被写进Windows.UI为前缀的命名空间中,可以看出微软wp8.1经过了一定的优化. 此处功能设计描述为,触摸一次返回键,提示是否退出app,再点一次即关闭app. 1 <Grid Background="#F5F5F5" DataContext="{Binding Path=MainPageViewModel

Android使用ShowcaseView添加半透明操作提示图片的方法

http://beeder.github.io/2014/11/11/how-to-add-a-semi-transparent-demo-screen-using-showcaseview/ 这篇文章详细介绍了怎样使用ShowcaseView添加半透明操作提示图片的方法,以及完整源代码. 效果图如下:

flutter Tooltip轻量级操作提示

Tooltip是继承于StatefulWidget的一个Widget,它并不需要调出方法,当用户长按被Tooltip包裹的Widget时,会自动弹出相应的操作提示. import 'package:flutter/material.dart'; class ToolTipDemo extends StatelessWidget { @override Widget build(BuildContext context) { return Scaffold( appBar: AppBar(titl

关于Visio的vba操作，遍历目录，对所有vsd文件操作，导入excel文件

1.vba遍历要添加引用,runtime 2.不能打开单独的application,因为在获取到shape的picture属性时候,新打开的application不能够获取到.提示自动化错误. 3.定位shape的话,需要shape的宽高,因为是基于中心点的定位.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU 设置属性的格式如此,没有好办法了. 4.shape的name,text可以赋值,通过name的唯一性来判

八： 操作提示（wxml 即将废弃）

首先需要注意的是 wxml的这些属性将要被废弃,不过可以看两眼.不愿意看的可以看下一章节同样是操作回馈只不过是js版的哦.   一.action-sheet 操作菜单 从屏幕底下出来菜单. 这里不用w3c的代码了,他给的例子是闭包.麻烦而且新手不好理解.事实上真正写代码的时候,至少在这个地方不会用到闭包. /* ---page/test/test.wxml----*/ <button type="default" bindtap="actionSheetTap"