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

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

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

Интеграция Dlubal RFEM Type Library

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

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

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

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

Option Explicit

'--------------------------------------------------------------------------
' Закрытие окна с помощью кнопки «Отмена»
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Открытие процедуры перемещения/копирования направляющих и закрытию окна с помощью кнопки ОК.
'--------------------------------------------------------------------------
Private Sub cmdOK_Click()
If txbAnz.Value = "" Then
txbAnz.Value =

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

'--------------------------------------------------------------------------
' Функция для допуска лишь десятичных знаков
'--------------------------------------------------------------------------
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 <>

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

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, как описано в данной статье.