VBA COM-接口 | 5. 生成复制和平移辅助线的工具

技术文章

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

添加链接

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

图 01 - 链接 Dlubal RFEM Type Library

输入对话框

输入对话框需要设定输入位移向量以及复制的数量。在 VBA-编辑器中使用"添加" -> "用户形式" 可以建立用户自定义的输入对话框形式。然后需要在用户自定义形式中设置必须的控制按钮。需要在工具栏中选择控制按钮然后再添加到用户自定义形式中。另外用户可以在特征属性窗口中定义控制按钮的大小、位置、名称等属性。

图 02 - 输入对话框

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

Option Explicit

'--------------------------------------------------------------------------
' Close window when clicking Cancel
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
 frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Open procedure to move/copy the guidelines and close window when clicking OK
'--------------------------------------------------------------------------
Private Sub cmdOK_Click()
 If txbAnz.Value = "" Then
  txbAnz.Value = 0
 End If
 If txbX.Value = "" Then
  txbX.Value = 0
 End If
 If txbY.Value = "" Then
  txbY.Value = 0
 End If
 If txbZ.Value = "" Then
  txbZ.Value = 0
 End If
 Call modGuideline.SetGuidelines(txbAnz.Value, txbX.Value, txbY.Value, txbZ.Value)
 frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Function to allow only decimals
'--------------------------------------------------------------------------
Private Function TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
 Select Case 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
  Case 48 To 57, 8, 96 To 105, 37, 39, 46: TxT_KeyDown = iKeyCode
  ' Only allow one minus sign at first position
  ' 109 Minus (numeric keypad)
  ' 189 Minus
  Case 109, 189:
   If InStr(1, objTextBox, "-", vbTextCompare) > 0 Or 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
  Case 190, 188, 110:
   If InStr(1, objTextBox, ",", vbTextCompare) > 0 Or objTextBox.SelStart = 0 Then
    TxT_KeyDown = 0
   Else
    TxT_KeyDown = 188
   End If
  ' Ignore all other signs
  Case Else: TxT_KeyDown = 0
 End Select
End Function

'--------------------------------------------------------------------------
' Allow only decimals to enter X coordinate
'--------------------------------------------------------------------------
Private Sub txbX_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
 iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Allow only decimals to enter Y coordinate
'--------------------------------------------------------------------------
Private Sub txbY_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
 iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Allow only decimals to enter Z coordinate
'--------------------------------------------------------------------------
Private Sub txbZ_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
 iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Only allow integers to enter the number of copies
'--------------------------------------------------------------------------
Private Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
 Select Case iKeyCode
  ' Only allow numbers from 0-9
  Case 48 To 57
  ' Ignore all other signs
  Case Else: iKeyCode = 0
 End Select
End Sub

复制和平移辅助线

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

Option Explicit

Enum Errors
 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
End Enum

'--------------------------------------------------------------------------
' Procedure to move and copy selected guidelines
'--------------------------------------------------------------------------
Sub SetGuidelines(iAnz As Integer, dNodeX, dNodeY, dNodeZ As Double)
Dim model As RFEM5.model
Dim app As RFEM5.Application
Dim guides As IGuideObjects
Dim lines() As Guideline
Dim iCountAll, iCountSel, i, iAnzKopie, iGuideNo As Integer
Dim newLayerLine As Guideline

 On Error GoTo ErrorHandler

 ' 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
 If app.GetModelCount > 0 Then
  Set model = app.GetActiveModel
 Else
 ' Raise error if no model is opened
  Err.Raise Errors.Err_Model
 End If

 ' Get interface for guidelines
 Set guides = model.GetGuideObjects

 ' Define numbers of guidelines
 model.GetModelData.EnableSelections (False)
 iCountAll = model.GetGuideObjects.GetGuidelineCount
 If iCountAll = 0 Then
 ' 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 (True)
 iCountSel = model.GetGuideObjects.GetGuidelineCount

 If iCountSel > 0 Then
  ' Copy selected guidelines
  guides.PrepareModification
  lines = guides.GetGuidelines()
  If iAnz > 0 Then
   For iAnzKopie = 1 To iAnz
    For i = 0 To 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 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 = lines(i).Type
     newLayerLine.Angle = lines(i).Angle
     newLayerLine.Radius = lines(i).Radius
     ' Guideline coordinates (X, Y, Z) of the copy will be adjusted by the displacement vector
     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(lines(i).No)
     guides.SetGuideline newLayerLine
    Next
    iCountAll = iCountAll + iCountSel
    iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No
   Next
  ' Moving selected guidelines
  Else
   For i = 0 To 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
    ' Guideline coordinates (X, Y, Z) will be adjusted by the displacement vector
    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
   Next
   guides.SetGuidelines lines
  End If
  guides.FinishModification
 Else
 ' Cause error if no guidelines are selected
 Err.Raise Errors.Err_Guideline_sel
 End If

' Error handling
ErrorHandler:
  If Err.Number <> 0 Then
   Select Case Err.Number
    Case Errors.Err_RFEM
     MsgBox ("RFEM is not opened")
     Exit Sub
    Case Errors.Err_Model
     MsgBox ("No file opened!")
    Case Errors.Err_Guideline
     MsgBox ("No guidelines available in file " & model.GetName & " !")
    Case Errors.Err_Guideline_sel
     MsgBox ("No guidelines selected in file " & model.GetName & " !")
    Case Else
     MsgBox "Error-Nr. : " & Err.Number & vbLf & Err.Description
   End Select
  End If
 ' COM licence is unlocked, programme access possible again
 app.UnlockLicense

 Set app = Nothing
 Set model = Nothing
 Set guides = Nothing

End Sub

'--------------------------------------------------------------------------
' Initialisation
'--------------------------------------------------------------------------
Sub init()
 frmGuideline.txbX.Value = "0"
 frmGuideline.txbY.Value = "0"
 frmGuideline.txbZ.Value = "0"
 frmGuideline.txbAnz.Value = "0"
End Sub

'--------------------------------------------------------------------------
' Function to check if RFEM is opened
'--------------------------------------------------------------------------
Function RFEM_open() As Boolean
Dim objWMI, colPro As Object

 Set objWMI = GetObject("winmgmts:" _
          & "{impersonationLevel=impersonate}!\\" & "." & "\root\cimv2")
 Set colPro = objWMI.ExecQuery _
          ("Select * from Win32_Process Where Name = 'RFEM64.exe'")
 If colPro.Count = 0 Then
  RFEM_open = False
 Else
  RFEM_open = True
 End If
End Function

总结和展望

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

下载

更多信息

联系我们

联系 Dlubal

如果您有任何关于我们产品的问题或者建议,请联系我们的技术支持或者搜索我们的问题和解答 (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