COM Interface in VBA | 5. Creating a Tool to Copy and Move Guidelines

Technical Article

This article was translated by Google Translator View original text
RF-COM/RS-COM is a programmable interface which allows the user to expand the main programmes RFEM and RSTAB by customized input macros or post‑processing programmes. In this article, a tool to copy and move selected guidelines in RFEM will be developed. It is possible to copy or move the guidelines also to another work plane. VBA in Excel will be used as programming environment.

Inserting Link

The RFEM object library has to be integrated to the VBA editor first by pointing to "Tools" → "References".

[LinkToImage01]

Input Table

The displacement vector as well as the number of copies should be entered in the input table. To create the input table, a userform will be generated by pointing to "Insert" - "UserForm" in the VBA editor. The necessary controls will be then placed on the userform. For this purpose, the respective control has to be selected in the toolbox and then saved on the userform. The properties such as size, position, name of the userform and the controls can be defined in the properties window.

[LinkToImage02]

For the displacement vector, only decimals and for the number of copies only integers should be allowed as input data. The source code of the input table is listed below.

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

Moving and Copying Guidelines

The source code to move and copy the selected guidelines is listed below. The single steps are explained in the comments.

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

Summary and Outlook

In the article, a tool to move/copy guidelines in RFEM has been developed. In the same way, a corresponding tool for RSTAB can be created. The tool is started via the interface of Excel. It is also possible to integrate this tool into RFEM or RSTAB as described in this article.

Keywords

COM API VBA Guideline

Downloads

Links

Contact us

Contact to Dlubal

Do you have questions or need advice?
Contact our free e-mail, chat, or forum support or find various suggested solutions and useful tips on our FAQ page.

+49 9673 9203 0

info@dlubal.com

RFEM Main Program
RFEM 5.xx

Main Program

Structural engineering software for finite element analysis (FEA) of planar and spatial structural systems consisting of plates, walls, shells, members (beams), solids and contact elements

Price of First License
3,540.00 USD
RSTAB Main Program
RSTAB 8.xx

Main Program

The structural engineering software for design of frame, beam and truss structures, performing linear and nonlinear calculations of internal forces, deformations, and support reactions

Price of First License
2,550.00 USD
RFEM Other
RF-COM 5.xx

Add-on Module

Programmable interface (API) based on the COM technology

Price of First License
580.00 USD
RSTAB Other
RS-COM 8.xx

Add-on Module

Programmable interface (API) based on the COM technology

Price of First License
580.00 USD