VBA中的COM接口 | 5. 创建复制和移动辅助线的工具

添加链接

RFEM 的对象数据库可以在 VBA 编辑器中通过下拉菜单 "工具" → "链接" 进行激活。

链接 Dlubal RFEM Type Library

输入对话框

输入对话框需要设定输入位移向量以及复制的数量。 为了创建输入表，在VBA编辑器中点击“ Insert”->“ UserForm”生成一个用户表格。 然后需要在用户自定义形式中设置必须的控制按钮。 需要在工具栏中选择控制按钮然后再添加到用户自定义形式中。 另外用户可以在特征属性窗口中定义控制按钮的大小、位置、名称等属性。

输入对话框

需要注意的是所输入的位移向量可以为十进制小数，并且复制的数目只能是整数形式。 下文显示上述所编写的程序源文本代码。

Option Explicit

'------------------------------------------------- -------------------------
' Close window when clicking Cancel
'------------------------------------------------- -------------------------
私人子 cmdClose_Click（）
frmGuideline.Hide
结束子

'------------------------------------------------- -------------------------
' Open procedure to move/copy the guidelines and close window when clicking OK
'------------------------------------------------- -------------------------
私人子 cmdOK_Click（）
If txbAnz.Value =“”然后
txbAnz.Value =

输入对话框

'------------------------------------------------- -------------------------
' Function to allow only decimals
'------------------------------------------------- -------------------------
私有函数 TxT_KeyDown（objTextBox As MSForms.TextBox，iKeyCode 作为整数)作为整数
选择案例 iKeyCode
' Allow the following signs:
' 8 Backspace key to correct
' 48-57 Numbers from 0 to 9
' 96-105 Numbers from 0 to 9 (numeric keypad)
' 37, 39 Cursor key ()
' 46 Del key
工况 48 收件人 57,8,96 收件人 105,37,39,46: TxT_KeyDown = iKeyCode
' Only allow one minus sign at first position
' 109 Minus (numeric keypad)
' 189 Minus
工况 109,189:
If InStr（1，objTextBox，“-”，vbTextCompare）> 0 或objTextBox.SelStart <> 0 然后
TxT_KeyDown = 0
Else
TxT_KeyDown = 109
End If
' Only allow one comma or point and replace point by comma
' 188 Comma
' 110 Comma (Nummernblock)
' 190 Point
工况 190,188,110:
If InStr（1，objTextBox，“，”，vbTextCompare）> 0 或者 objTextBox.SelStart = 0 然后
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignore all other signs
其他情况: TxT_KeyDown = 0
结束选择
最终功能

'------------------------------------------------- -------------------------
' Allow only decimals to enter X coordinate
'------------------------------------------------- -------------------------
私人子 txbX_KeyDown（ByVal iKeyCode为MSForms.ReturnInteger，ByVal Shift为Integer）
iKeyCode = TxT_KeyDown（txbX，CInt（iKeyCode））
结束子

'------------------------------------------------- -------------------------
' Allow only decimals to enter Y coordinate
'------------------------------------------------- -------------------------
私人子txbY_KeyDown（ByVal iKeyCode As MSForms.ReturnInteger， ByVal 移位作为整数)
iKeyCode = TxT_KeyDown（txbY， CInt（iKeyCode））
结束子

'------------------------------------------------- -------------------------
' Allow only decimals to enter Z coordinate
'------------------------------------------------- -------------------------
私人子 txbZ_KeyDown（ByVal iKeyCode As MSForms.ReturnInteger， ByVal 移位作为整数)
iKeyCode = TxT_KeyDown（txbZ， CInt（iKeyCode））
结束子

'------------------------------------------------- -------------------------
' Only allow integers to enter the number of copies
'------------------------------------------------- -------------------------
私人子 txbAnz_KeyPress（ByVal iKeyCode As MSForms.ReturnInteger）
选择案例 iKeyCode
' Only allow numbers from 0-9
工况 48 收件人 57
' Ignore all other signs
其他情况: iKeyCode = 0
结束选择
结束子

复制和平移辅助线

下面列出了复制和平移辅助线的源代码，在注释中解释单个步骤。 在注释中解释单个步骤。

Option Explicit

枚举 错误
Err_RFEM = 513 'RFEM未打开
Err_Model = 514 '没有打开模型
Err_Guideline = 515 '没有指南
Err_Guideline_sel = 516 '没有选择参考线
结束枚举

'------------------------------------------------- -------------------------
' Procedure to move and copy selected guidelines
'------------------------------------------------- -------------------------
子 SetGuidelines（iAnz 作为整数，dNodeX，dNodeY，dNodeZ 作为双)
暗淡 模型 As RFEM5.model
暗淡 应用 As RFEM5.Application
暗淡 指南 As IGuideObjects
暗淡 lines（） As 指南
暗淡 iCountAll，iCountSel，i，iAnzKopie，iGuideNo 作为整数
暗淡 newLayerLine As 指南

出现错误时转到 ErrorHandler

' Get interface to RFEM
If RFEM_open = 则为真
集 app = GetObject（，“ RFEM5.Application”）
Else
' Raise error if RFEM is not opened
Err.Raise Errors.Err_RFEM
End If

' Block COM licence and programme access
app.LockLicense

' Get interface for active model
If app.GetModelCount> 0 然后
集 模型= app.GetActiveModel
Else
' Raise error if no model is opened
Err.Raise Errors.Err_Model
End If

' Get interface for guidelines
集 参考线= model.GetGuideObjects

' Define numbers of guidelines
model.GetModelData.EnableSelections（假)
iCountAll = model.GetGuideObjects.GetGuidelineCount
If iCountAll = 0 然后
' Raise error if no guidelines are available
Err.Raise Errors.Err_Guideline
End If
iGuideNo = guides.GetGuideline（iCountAll- 1，AtIndex）.GetData.No

' Define numbers of selected guidelines
model.GetModelData.EnableSelections（真)
iCountSel = model.GetGuideObjects.GetGuidelineCount

If iCountSel> 0 然后
' Copy selected guidelines
guides.PrepareModification
lines = guides.GetGuidelines（）
If iAnz> 0 然后
关于技术提问和解答： iAnzKopie = 1 收件人 iAnz
关于技术提问和解答： i = 0 收件人 iCountSel- 1
newLayerLine.WorkPlane = lines（i）.WorkPlane
' Create new work plane if guideline should be copied to another work plane
If （lines（i）.WorkPlane = PlaneXY 并且 dNodeZ <>

输入对话框

结束子

'------------------------------------------------- -------------------------
' Initialisation
'------------------------------------------------- -------------------------
子 init（）
frmGuideline.txbX.Value =“ 0”
frmGuideline.txbY.Value =“ 0”
frmGuideline.txbZ.Value =“ 0”
frmGuideline.txbAnz.Value =“ 0”
结束子

'------------------------------------------------- -------------------------
' Function to check if RFEM is opened
'------------------------------------------------- -------------------------
功能 RFEM_open（） 作为布尔
暗淡 objWMI，colPro 作为对象

集 objWMI = GetObject（“ winmgmts：” _
＆“ {impersonationLevel = impersonate}！\\”＆“。 ＆“ \ root \ cimv2”）
集 colPro = objWMI.ExecQuery _
（“从Win32_Process中选择*，其中Name ='RFEM64.exe'”）
If colPro.Count = 0 然后
RFEM_open = 假
Else
RFEM_open = 真
End If
最终功能

总结和展望

本文讲述了如何在 RFEM 中编写程序命令流并创建平移/复制的用户自定义工具。 该方法也可以用于在 RSTAB 中创建相关的工具。 自定义工具可以在 EXCEL 的用户界面中启动。 如本文所述，也可以将该工具集成到RFEM或RSTAB中。