Интерфейс COM в VBA | 5. Создание инструмента для копирования и перемещения направляющих

Техническая статья

RF-COM/RS-COM - это программируемый интерфейс, который позволяет пользователю расширять основные программы RFEM и RSTAB с помощью настраиваемых входных макросов или программ пост-обработки. В данной статье будет представлен инструмент для копирования и перемещения выбранных направляющих в RFEM. Можно скопировать или переместить направляющие также в другую рабочую плоскость. VBA в Excel будет использоваться в качестве среды программирования.

Вставка ссылки

База данных объектов RFEM должна быть сначала интегрирована в редактор VBA, с указанием на «Инструменты» → «Ссылки».

Pисунок 01 - Интеграция Dlubal RFEM Type Library

Таблица ввода

Вектор перемещения, а также количество копий должны быть заданы во входной таблице. Для создания входной таблицы, в редакторе VBA необходимо заложить пользовательскую форму, с помощью «Вставить» - «UserForm». Затем необходимые элементы управления будут помещены в пользовательскую форму. Для этой цели соответствующий элемент управления должен быть выбран в панели инструментов, а затем сохранен в пользовательской форме. Свойства, такие как размер, положение, имя пользовательской формы и элементов управления, могут быть заданы в окне свойств.

Pисунок 02 - Таблица ввода

Для вектора перемещения в качестве входных данных должны быть разрешены только десятичные числа, а для количества копий - только целые числа. Исходный код входной таблицы приведен ниже.

Option Explicit

'--------------------------------------------------------------------------
' Закройте окно при нажатии Отмена
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Откройте процедуру перемещения/копирования направляющих и закройте окно нажатием кнопки ОК.
'--------------------------------------------------------------------------
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

'--------------------------------------------------------------------------
' Функция допускает только десятичные знаки
'--------------------------------------------------------------------------
Private Function TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Select Case iKeyCode
' Разрешить следующие знаки:
' 8 Клавиша Backspace для исправлений
' 48-57 Номера от 0 до 9
' 96-105 Номера от 0 до 9 (цифровая клавиатура)
' 37, 39 Клавиши курсора ()
' 46 Клавиша Del
Case 48 To 57, 8, 96 To 105, 37, 39, 46: TxT_KeyDown = iKeyCode
' Разрешить только один знак минус на первой позиции
' 109 Минус (цифровая клавиатура)
' 189 Минус
Case 109, 189:
If InStr(1, objTextBox, "-", vbTextCompare) > 0 Or objTextBox.SelStart <> 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 109
End If
' Разрешить только запятую или точку и заменять точку запятой
' 188 Запятая
' 110 Запятая (цифровая клавиатура)
' 190 Точка
Case 190, 188, 110:
If InStr(1, objTextBox, ",", vbTextCompare) > 0 Or objTextBox.SelStart = 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Игнорировать все остальные знаки
Case Else: TxT_KeyDown = 0
End Select
End Function

'--------------------------------------------------------------------------
' Разрешить только десятичные числа для ввода координаты X
'--------------------------------------------------------------------------
Private Sub txbX_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Разрешить только десятичные числа для ввода координаты Y
'--------------------------------------------------------------------------
Private Sub txbY_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Разрешить только десятичные числа для ввода координаты Z
'--------------------------------------------------------------------------
Private Sub txbZ_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Разрешить целые числа для ввода количества копий
'--------------------------------------------------------------------------
Private Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
Select Case iKeyCode
' Разрешить только числа от 0 до 9
Case 48 To 57
' Игнорировать все остальные знаки
Case Else: iKeyCode = 0
End Select
End Sub

Перемещение и копирование направляющих

Исходный код для перемещения и копирования выбранных направляющих приведен ниже. Отдельные шаги объясняются в комментариях.

Option Explicit

Enum Errors
Err_RFEM = 513 ' RFEM не открывается
Err_Model = 514 ' Модель не открывается
Err_Guideline = 515 ' Направляющие недоступны
Err_Guideline_sel = 516 ' Направляющие не выбраны
End Enum

'--------------------------------------------------------------------------
' Процедура перемещения и копирования выбранных направляющих
'--------------------------------------------------------------------------
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

' Переключить на интерфейс к RFEM
If RFEM_open = True Then
Set app = GetObject(, "RFEM5.Application")
Else
' Отстранить ошибку, если RFEM не открывается
Err.Raise Errors.Err_RFEM
End If

' Блокировать лицензию COM и доступ к программе
app.LockLicense

' Переключить на интерфейс для активной модели
If app.GetModelCount > 0 Then
Set model = app.GetActiveModel
Else
' Отстранить ошибку, если модель не открывается
Err.Raise Errors.Err_Model
End If

' Переключить на интерфейс для направляющих
Set guides = model.GetGuideObjects

' Задать количество направляющих
model.GetModelData.EnableSelections (False)
iCountAll = model.GetGuideObjects.GetGuidelineCount
If iCountAll = 0 Then
' Отстранить ошибку, если направляющие недоступны
Err.Raise Errors.Err_Guideline
End If
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No

' Задать количество выбранных направляющих
model.GetModelData.EnableSelections (True)
iCountSel = model.GetGuideObjects.GetGuidelineCount

If iCountSel > 0 Then
' Копировать выбранные направляющие
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
' Создать новую рабочую плоскость, если направляющие должно быть скопированы на другую рабочую плоскость
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
' Направляющие в той же рабочей плоскости
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(lines(i).No)
guides.SetGuideline newLayerLine
Next
iCountAll = iCountAll + iCountSel
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No
Next
' Перемещение выбранных направляющих
Else
For i = 0 To iCountSel - 1
' Перемещение направляющих в другую рабочую плоскость
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
Next
guides.SetGuidelines lines
End If
guides.FinishModification
Else
' Отстранить ошибку, если направляющие не выбраны
Err.Raise Errors.Err_Guideline_sel
End If

' Обработка ошибок
ErrorHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case Errors.Err_RFEM
MsgBox ("RFEM не открывается")
Exit Sub
Case Errors.Err_Model
MsgBox ("Файл не открывается!")
Case Errors.Err_Guideline
MsgBox ("Недоступны направляющие в файле " & model.GetName & " !")
Case Errors.Err_Guideline_sel
MsgBox ("Не выбраны направляющие в файле " & model.GetName & " !")
Case Else
MsgBox "Error-Nr. : " & Err.Number & vbLf & Err.Description
End Select
End If
' Лицензия COM разблокирована, доступ к программе обновлен
app.UnlockLicense

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

End Sub

'--------------------------------------------------------------------------
' Запуск
'--------------------------------------------------------------------------
Sub init()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub

'--------------------------------------------------------------------------
' Функция для проверки, открыт ли RFEM
'--------------------------------------------------------------------------
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

У вас есть какие-либо вопросы или необходим совет?
Свяжитесь с нами или ознакомьтесь с различными предлагаемыми решениями и полезными советами на странице часто задаваемых вопросов.

+49 9673 9203 0

info@dlubal.com

RFEM Основная программа
RFEM 5.xx

Основная программа

Программное обеспечение для расчета конструкций методом конечных элементов (МКЭ) плоских и пространственных конструктивных систем, состоящих из плит, стен, оболочек, стержней (балок), тел и контактных элементов

Цена первой лицензии
3 540,00 USD
RSTAB Основная программа
RSTAB 8.xx

Основная программа

Программное обеспечение для расчета конструкций рам, балок и ферм, выполняющее линейные и неьинейные расчеты внутренних сил, деформаций и опорных реакций

Цена первой лицензии
2 550,00 USD
RFEM Прочие
RF-COM 5.xx

Дополнительный модуль

Программируемый интерфейс (API), основанный на технологии COM

Цена первой лицензии
580,00 USD