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

技术文章

This article was translated by Google Translator

View original text

RF-COM/RS-COM 是一种可以由用户自编程的软件接口,使用此接口用户可以根据实际需要在主程序 RFEM/RSTAB 中添加建模输入的方法或者导出计算结果的后续处理分析等。 本文将阐述如何在 RFEM 中编写用于已选定辅助线的复制和平移工具。 辅助线也可以在其他的工作平面中进行复制和平移操作。 使用此接口需要安装 Excel 使用 VBA 编程。

添加链接

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

图片 01 - 链接 Dlubal RFEM Type Library

输入对话框

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

图片 02 - 输入对话框

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

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()
如果 txbAnz.Value =“”然后
txbAnz.Value = 图片 02 - 输入对话框
End If
如果 txbX.Value =“” 然后
txbX.Value = 0
End If
如果 txbY.Value =“” 然后
txbY.Value = 0
End If
如果 txbZ.Value =“” 然后
txbZ.Value = 0
End If
呼叫 modGuideline.SetGuidelines(txbAnz.Value,txbX.Value,txbY.Value,txbZ.Value)
frmGuideline.Hide
结束子

'------------------------------------------------- -------------------------
' Function to allow only decimals
'------------------------------------------------- -------------------------
私有函数 TxT_KeyDown(objTextBox 作为 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:
如果 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:
如果 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 作为 MSForms.ReturnInteger, ByVal 移动作为整数)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
结束子

'------------------------------------------------- -------------------------
' Allow only decimals to enter Z coordinate
'------------------------------------------------- -------------------------
私人子 txbZ_KeyDown(ByVal iKeyCode 作为 MSForms.ReturnInteger, ByVal 移动作为整数)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
结束子

'------------------------------------------------- -------------------------
' Only allow integers to enter the number of copies
'------------------------------------------------- -------------------------
私人子 txbAnz_KeyPress(ByVal iKeyCode 作为 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 作为双)
暗淡 模型 作为 RFEM5.model
暗淡 应用 作为 RFEM5.Application
暗淡 指南 作为 IGuideObjects
暗淡 lines() 作为 辅助线
暗淡 iCountAll,iCountSel,i,iAnzKopie,iGuideNo 作为整数
暗淡 newLayerLine 作为 辅助线

出现错误时转到 ErrorHandler

' Get interface to RFEM
如果 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
如果 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
如果 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

如果 iCountSel> 0 然后
' Copy selected guidelines
guides.PrepareModification
lines = guides.GetGuidelines()
如果 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
如果 (lines(i).WorkPlane = PlaneXY 并且 dNodeZ <> 图片 02 - 输入对话框 )然后
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ * iAnzKopie
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
否则 (lines(i).WorkPlane = PlaneYZ 并且 dNodeX <> 0)然后
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X + dNodeX * iAnzKopie
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z
否则 (lines(i).WorkPlane = PlaneXZ 并且 dNodeY <> 0)然后
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 = lines(i).Type
newLayerLine.Angle = lines(i).Angle
newLayerLine.Radius = lines(i).Radius
'复制的参考坐标(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.No = iGuideNo + i + 1
newLayerLine.Description =“ Kopie Hilfslinie” + CStr(第(i)行。
guides.SetGuideline newLayerLine
下一个
iCountAll = iCountAll + iCountSel
iGuideNo = guides.GetGuideline(iCountAll- 1,AtIndex).GetData.No
下一个
' Moving selected guidelines
Else
对于 i = 0 结束 iCountSel- 1
' Moving guidelines to another work plane
如果 (lines(i).WorkPlane = PlaneXY 并且 dNodeZ <> 0)然后
lines(i).WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ
否则 (lines(i).WorkPlane = PlaneYZ 并且 dNodeX <> 0)然后
lines(i).WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X + dNodeX
否则 (lines(i).WorkPlane = PlaneXZ 并且 dNodeY <> 0)然后
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.Raise Errors.Err_Guideline_sel
End If

' Error handling
ErrorHandler:
如果 错误编号<> 0 然后
选择案例 错误编号
情况 错误。
MsgBox ("RFEM is not opened")
出口子
情况 Errors.Err_Model
MsgBox ("No file opened!")
情况 错误。
MsgBox ("No guidelines available in file " & model.GetName & " !")
情况 错误.Err_Guideline_sel
MsgBox ("No guidelines selected in file " & model.GetName & " !")
其他情况
MsgBox“错误编号: : “&Err.Number&vbLf&Err.Description
结束选择
End If
' COM licence is unlocked, programme access possible again
app.UnlockLicense

设置 app = 一无所有
设置 模型= 一无所有
设置 指南= 一无所有

结束子

'------------------------------------------------- -------------------------
' 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'”)
如果 colPro.Count = 0 然后
RFEM_open = 错误
Else
RFEM_open = 正确
End If
最终功能

总结和展望

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

关键词

COM API VBA 辅助线

下载

更多信息

联系我们

如果您有任何关于我们产品的问题或者建议,请联系我们的技术支持或者搜索我们的问题和解答 (FAQs)。

+49 9673 9203 0

(可要求接中文热线)

info@dlubal.com

RFEM 主程序 RFEM
RFEM 5.xx

主程序

结构设计与有限元­分析软件(FEA)可以用于建立 平面与空间结构模型,适用于由杆件、面、 板、墙、折板、膜、壳、实体以及接触单元等的建模与分析计算。

首个许可价格
3,540.00 USD
RSTAB 主程序
RSTAB 8.xx

主程序

空间结构设计与分析软件,主要用于框架、梁与桁架等空间结构的建模与计算。可以输出内力、变形与制作反力的线性与非线性的计算结果。

首个许可价格
2,550.00 USD
RFEM 其他附加模块
RF-COM 5.xx

附加模块

RFEM 可编程序的 COM 接口

首个许可价格
580.00 USD
RSTAB 其他附加模块
RS-COM 8.xx

附加模块

RSTAB 中可编程序的 COM 接口

首个许可价格
580.00 USD