添加链接
RFEM 的对象数据库可以在 VBA 编辑器中通过下拉菜单 "工具" → "链接" 进行激活。
输入对话框
输入对话框需要设定输入位移向量以及复制的数量。 在 VBA 编辑器中通过"插入" → "用户形式" 可以创建用户自定义对话框。 然后需要在用户自定义形式中设置必须的控制按钮。 需要在工具栏中选择控制按钮然后再添加到用户自定义形式中。 另外用户可以在特征属性窗口中定义控制按钮的大小、位置、名称等属性。
需要注意的是所输入的位移向量可以为十进制小数，并且复制的数目只能是整数形式。 下文显示上述所编写的程序源文本代码。
- code.py#
Option Explicit
'—————————————————————— 9 - 18 - 12
' Close window when clicking Cancel
'—————————————————————— 9 - 18 - 12
Private Sub cmdClose_Click()
frm辅助线.隐藏
末端接头
'—————————————————————— 9 - 18 - 12
' Open procedure to move/copy the guidelines and close window when clicking OK
'—————————————————————— 9 - 18 - 12
Private Sub cmdOK_Click()
如果 txbNum.Value = "" 那么
txbNumber.Value = 0
End If
如果 txbX.Value = "" 则
txbX.Value = 0
End If
如果 txbY.Value = "" 那么
txbY.值 = 0
End If
如果 txbZ.Value = "" 则
txbZ.值 = 0
End If
Call modGuideline.SetGuidelines(txbAnz.Value, txbX.Value, txbY.Value, txbZ.Value)
frm辅助线.隐藏
末端接头
'—————————————————————— 9 - 18 - 12
' Function to allow only decimals
'—————————————————————— 9 - 18 - 12
Private Function TxT_keyDown（objTextbox As MSForms.Textbox，ikeycode作为整数）As Integer
选择工况 ikey 代码
' 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 Then
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 Then
TxT_keyDown = 0
Else
第188章
End If
' Ignore all other signs
其他情况： TxT_keyDown = 0
末端选择
末端功能
'—————————————————————— 9 - 18 - 12
' Allow only decimals to enter X coordinate
'—————————————————————— 9 - 18 - 12
Private Sub txbX_keyDown（byval ikeycode As MSForms.ReturnInteger，byval shift As integer）
ikeycode = txt_keydown（txbx，CInt（ikeycode））
末端接头
'—————————————————————— 9 - 18 - 12
' Allow only decimals to enter Y coordinate
'—————————————————————— 9 - 18 - 12
Private Sub txbY_keyDown（byval ikeycode As MSForms.ReturnInteger，byval shift As integer）
ikeycode = txt_keydown（txby，CInt（ikeycode））
末端接头
'—————————————————————— 9 - 18 - 12
' Allow only decimals to enter Z coordinate
'—————————————————————— 9 - 18 - 12
Private Sub txbZ_keyDown（byval ikeycode As MSForms.ReturnInteger，byval shift As integer）
ikeycode = txt_keydown（txbz，CInt（ikeycode））
末端接头
'—————————————————————— 9 - 18 - 12
' Only allow integers to enter the number of copies
'—————————————————————— 9 - 18 - 12
Private Sub txbAnz_keyPress（byval ikeycode As MSForms.ReturnInteger）
选择工况 ikey 代码
' Only allow numbers from 0-9
工况 48 至 57
' Ignore all other signs
其他情况： i按键代码 = 0
末端选择
末端接头
- /代码#
复制和平移辅助线
下面列出了复制和平移辅助线的源代码，在注释中解释单个步骤。 在注释中对各个步骤进行了说明。
- code.py#
Option Explicit
枚举错误
Err_RFEM = 513 ' RFEM not opened
Err_Model = 514 ' No model opened
Err_Guideline = 515 ' No guideline available
Err_Guideline_sel = 516 ' No guidelines selected
枚举结束
'—————————————————————— 9 - 18 - 12
' Procedure to move and copy selected guidelines
'—————————————————————— 9 - 18 - 12
Sub SetGuidelines (i No. As Integer，dNodeX、dNodeY、dNodeZ As Double)
Dim model 同 RFEM5.model
Dim app As RFEM5.Application
Dim 辅助线作为 IGuideObject
将线定义()
Dim icountall、icountsel、i、iAnzCopy、iGuideno As Integer
将新建图层线作为辅助线变暗
错误时转到错误处理程序
' Get interface to RFEM
If RFEM_open = True Then
Set 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
如果 app.GetModelcount > 0 则
Set model = app.GetactiveModel
Else
' Raise error if no model is opened
出错.产生错误.Err_Model
End If
' Get interface for guidelines
Set guides = model.GetGuideObjects
' Define numbers of guidelines
model.GetModelData.EnableSelections（False）
icountall = model.getguideobjects.getguidelinecount
如果 icountAll = 0，则
' Raise error if no guidelines are available
出错.产生错误.Err_Guideline
End If
iGuide No = guides.GetGuideline(icountall - 1, atindex).getdata.no
' Define numbers of selected guidelines
model.GetModelData.EnableSelections (True)
icountsel = model.getguideobjects.getguidelinecount
如果 IcountsSel > 0，则
' Copy selected guidelines
guides.PrepareModification
lines = guides.GetGuidelines()
如果 iNumber > 0 则
对于 iCo.Copy = 1 到 iCo
对于 i = 0 到 icountsel - 1
newLayerLine.WorkPlane = 线(i).WorkPlane
' Create new work plane if guideline should be copied to another work plane
If (lines(i) .WorkPlane = PlaneXY And dNodeZ <> 0) Then
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ * iAnzKopie
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
ElseIf (lines(i).WorkPlane = PlaneYZ And dNodeX <> 0) Then
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X + dNodeX * iAnzKopie
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z
ElseIf (lines(i).WorkPlane = PlaneXZ And dNodeY <> 0) Then
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y + dNodeY * iAnzKopie
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z
Else
' Guidelines in the same work plane
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z
End If
newLayerLine.Type = 线(i).类型
newLayerLine.Angle = 线(i).Angle
newLayerLine.Radius = 线(i).半径
' 复制的辅助线坐标 (X, Y, Z) 通过位移向量进行调整
newLayerLine.Point1.X = lines(i).Point1.X + dNodeX * iAnzKopie
newLayerLine.Point1.Y = lines(i).Point1.Y + dNodeY * iAnzKopie
newLayerLine.Point1.Z = lines(i).Point1.Z + dNodeZ * iAnzKopie
newLayerLine.Point2.X = lines(i).Point2.X + dNodeX * iAnzKopie
newLayerLine.Point2.Y = lines(i).Point2.Y + dNodeY * iAnzKopie
newLayerLine.Point2.Z = lines(i).Point2.Z + dNodeZ * iAnzKopie
newLayerLine.编号 = iGuide编号 + i + 1
newLayerLine.Description = "复制辅助线 " + CStr(lines(i). No)
guides.SetGuideline newLayerLine
更多
icountall = icountall + icountsel
iGuide No = guides.GetGuideline(icountall - 1, atindex).getdata.no
更多
' Moving selected guidelines
Else
对于 i = 0 到 icountsel - 1
' Moving guidelines to another work plane
If (lines(i) .WorkPlane = PlaneXY And dNodeZ <> 0) Then
lines(i).WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ
ElseIf (lines(i).WorkPlane = PlaneYZ And dNodeX <> 0) Then
lines(i).WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X + dNodeX
ElseIf (lines(i).WorkPlane = PlaneXZ And dNodeY <> 0) Then
lines(i).WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y + dNodeY
End If
' 辅助线坐标（X, Y, Z）通过位移向量进行调整
lines(i).Point1.X = lines(i).Point1.X + dNodeX
lines(i).Point1.Y = lines(i).Point1.Y + dNodeY
lines(i).Point1.Z = lines(i).Point1.Z + dNodeZ
lines(i).Point2.X = lines(i).Point2.X + dNodeX
lines(i).Point2.Y = lines(i).Point2.Y + dNodeY
lines(i).Point2.Z = lines(i).Point2.Z + dNodeZ
更多
guides.SetGuidelines 线
End If
guides.FinishModification
Else
' Cause error if no guidelines are selected
错误.增加错误.Err_Guideline_sel
End If
' Error handling
错误处理程序：
如果错误编号 <> 0 则
选择工况错误编号
工况错误.Err_RFEM
MsgBox ("RFEM is not opened")
退出子对话框
工况错误.Err_Model
MsgBox ("No file opened!")
工况错误.Err_Guideline
MsgBox ("No guidelines available in file " & model.GetName & " !")
工况错误.Err_Guideline_sel
MsgBox ("No guidelines selected in file " & model.GetName & " !")
其他情况
Msgbox "错误编号， : " & 错误编号 & vbLf & 错误描述
末端选择
End If
' COM licence is unlocked, programme access possible again
app.UnlockLicense
集 app = 无
设置模型 = 无
设置辅助线 = 无
末端接头
'—————————————————————— 9 - 18 - 12
' Initialisation
'—————————————————————— 9 - 18 - 12
sub()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
末端接头
'—————————————————————— 9 - 18 - 12
' Function to check if RFEM is opened
'—————————————————————— 9 - 18 - 12
函数 RFEM_open() As Boolean
Dim objWMI, colPro As Object
Set objWMI = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & "." & "\根\cimv2")
设置 colPro = objWMI.Execquery_
("Select * from Win32_Process Where Name = 'RFEM64.exe'")
如果 colPro.count = 0 则
RFEM_open = 假
Else
RFEM_open = True
End If
末端功能
- /代码#
总结和展望
本文讲述了如何在 RFEM 中编写程序命令流并创建平移/复制的用户自定义工具。 该方法也可以用于在 RSTAB 中创建相关的工具。 自定义工具可以在 EXCEL 的用户界面中启动。 也可以按照本文所述将此工具集成到 RFEM 或 RSTAB 中：