Вставка ссылки
Перед самим началом работы, нужно с помощьq меню «Инструменты» → «Ссылки» интегрировать в редактор VBA базу данных объектов из программы RFEM.
окна ввода данных
Вектор перемещения, а также количество копий всегда должны быть заданы в таблице ввода. Для создания входной таблицы, в редакторе VBA необходимо заложить пользовательскую форму, с помощью команды «Вставить» → «Пользовательская форма». в которую затем требуется поместить все необходимые элементы управления. Для этого необходимо выбрать в панели инструментов соответствующий элемент управления и сохранить его в пользовательской форме. Отдельные свойства пользовательской формы, и элементов, такие как размер, положение или имя можно задать дополнительно прямо в окне свойств.
Не забывайте также, что для вектора перемещения должны в качестве входных данных разрешено вводить только десятичные числа, а для количества копий - только целые числа. Ниже приводим пример исходного кода таблицы ввода.
- code.py#
Option Explicit
'--------------------------------------------------------------------------
' Закрытие окна с помощью кнопки «Отмена»
'--------------------------------------------------------------------------
Частный подчиненный cmdClose_Click()
frmGuideline.Hide
End Sub
'--------------------------------------------------------------------------
' Открытие процедуры перемещения/копирования направляющих и закрытию окна с помощью кнопки ОК.
'--------------------------------------------------------------------------
Частная подписка cmdOK_Click()
Если txbNum.value = "" Тогда
txbNumber.value = 0
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
End Sub
'--------------------------------------------------------------------------
' Функция для допуска лишь десятичных знаков
'--------------------------------------------------------------------------
Частная функция TxT_KeyDdown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Выбрать случай iKeyCode
' Разрешены следующие знаки:
' 8 Клавиша Backspace для исправлений
' 48-57 Номера от 0 до 9
' 96-105 Номера от 0 до 9 (цифровая клавиатура)
' 37, 39 Клавиши курсора ()
' 46 Клавиша Del
Случай 48 До 57, 8, 96 До 105, 37, 39, 46: TxT_KeyDown = iKeyCode
' Разрешить только один знак минус на первой позиции
' 109 Минус (цифровая клавиатура)
' 189 Минус
Случай 109, 189:
Если InStr(1, objTextBox, "-", vbTextCompare) > 0 или objTextBox.SelStart <> 0 Тогда
TxT_KeyDdown = 0
Else
TxT_KeyDdown = 109
End If
' Разрешить только запятую или точку и заменять точку запятой
' 188 Запятая
' 110 Запятая (цифровая клавиатура)
' 190 Точка
Случай 190, 188, 110:
Если InStr(1, objTextBox, , vbTextCompare) > 0 или objTextBox.SelStart = 0 Тогда
TxT_KeyDdown = 0
Else
TxT_KeyDdown = 188
End If
' Игнорировать все остальные знаки
Ещё случай: TxT_KeyDdown = 0
End Select
End Function
'--------------------------------------------------------------------------
' Разрешить для ввода координаты X только десятичные числа
'--------------------------------------------------------------------------
Частный суб txbX_KeyDdown (ByVal iKeyCode As MSForms.ReternInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub
'--------------------------------------------------------------------------
' Разрешить для ввода координаты Y только десятичные числа
'--------------------------------------------------------------------------
Частный суб txbY_KeyDdown (ByVal iKeyCode As MSForms.ReternInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDdown (txbY, CIint (iKeyCode))
End Sub
'--------------------------------------------------------------------------
' Разрешить для ввода координаты Z только десятичные числа
'--------------------------------------------------------------------------
Частный суб txbZ_KeyDdown (ByVal iKeyCode As MSForms.ReternInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDdown (txbZ, CIint (iKeyCode))
End Sub
'--------------------------------------------------------------------------
' Разрешить для ввода количества копий только целые числа
'--------------------------------------------------------------------------
Частный заказчик txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReternInteger)
Выбрать случай iKeyCode
' Разрешить только числа от 0 до 9
Случай 48 - 57
' Игнорировать все остальные знаки
Ещё случай: iKeyCode = 0
End Select
End Sub
- /код#
Перемещение и копирование направляющих
Исходный код для перемещения и копирования выбранных направляющих приведен ниже. Отдельные шаги объясняются в комментариях.
- code.py#
Option Explicit
Ошибки перечисления
Err_RFEM = 513 ' RFEM не открывается
Err_Model = 514 ' Модель не открывается
Err_Guideline = 515 ' Направляющие недоступны
Err_Guideline_sel = 516 ' Направляющие не выбраны
End Enum
'--------------------------------------------------------------------------
' Процедура перемещения и копирования выбранных направляющих
'--------------------------------------------------------------------------
sub SetGuidelines (iNo. As Integer, dNodeX, dNodeY, dNodeZ As двойной)
Dim model As RFEM5.model
Размер приложения Как RFEM5.Application
Размеры направляющих как IGuideObjects
Размерные линии() Как направляющая
Dim icountall, icountsel, i, iAnzCopy, iGuideNo As Integer
Размеры новойлиниислоя как направляющей
При ошибке перейти к обработчику ошибок
' Переключить на интерфейс к RFEM
If RFEM_open = True Then
Set app = GetObject(, "RFEM5.Application")
Else
' Отстранить ошибку, если RFEM не открывается
Err.Raise Errors.Err_RFEM
End If
' Заблокировать лицензию COM и доступ к программе
app.LockLicense
' Переключить на интерфейс для активной модели
Еслиapp.GetModelColumn > 0 Тогда
Установить модель =app.GetActiveModel
Else
' Отстранить ошибку, если модель не открывается
Err.Raise Errors.Err_Model
End If
' Переключить на интерфейс для направляющих
Задать направляющие = model.GetGuideObjects
' Задать количество направляющих
model.GetModelData.EnableSelections(False)
iCountAll = model.GetGuideObjects.GetGuidelineCount
Если iColumnAll = 0, то
' Отстранить ошибку, если направляющие недоступны
Err.Raise Errors.Err_Guideline
End If
iGuideNo = направляющие.GetGuideline (iColumnAll - 1, AtIndex).GetData.No
' Задать количество выбранных направляющих
model.GetModelData.EnableSelections (True)
iCountSel = model.GetGuideObjects.GetGuidelineCount
Если icountSel > 0, то
' Копировать выбранные направляющие
guides.PrepareModification
lines = guides.GetGuidelines()
Если iNumber > 0, Тогда
Для iNo.Copy = 1 В iNo
For i = 0 To iColumnSel - 1
newLayerLine.WorkPlane = lines(i).WorkPlane
' Создать новую рабочую плоскость, если направляющие должны быть скопированы на другую рабочую плоскость
Если (lines(i) .WorkPlane = PlaneXY And dNodeZ <> 0), то
newLayerLine.WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ * iAnzKopie
newLayerLine.WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X
newLayerLine.WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y
ElseЕсли (lines(i).WorkPlane = PlaneYZ And 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
ElseЕсли (lines(i).WorkPlane = PlaneXZ And 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
' Направляющие в той же рабочей плоскости
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
новыйLayerLine.No = iGuideNo + i + 1
newLayerLine.Description = "Копировать направляющую " + CStr(lines(i).No)
guides.SetGuideline newLayerLine
Next
iCountAll = iCountAll + iCountSel
iGuideNo = направляющие.GetGuideline (iColumnAll - 1, AtIndex).GetData.No
Next
' Перемещение выбранных направляющих
Else
For i = 0 To iColumnSel - 1
' Перемещение направляющих в другую рабочую плоскость
Если (lines(i) .WorkPlane = PlaneXY And dNodeZ <> 0), то
lines(i).WorkPlaneOrigin.Z = lines(i).WorkPlaneOrigin.Z + dNodeZ
ElseЕсли (lines(i).WorkPlane = PlaneYZ And dNodeX <> 0) Тогда
lines(i).WorkPlaneOrigin.X = lines(i).WorkPlaneOrigin.X + dNodeX
ElseЕсли (lines(i).WorkPlane = PlaneXZ And dNodeY <> 0) Тогда
lines(i).WorkPlaneOrigin.Y = lines(i).WorkPlaneOrigin.Y + dNodeY
End If
' Регуляция kоординат направляющих (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
Выбрать случай Err.Number
Случай ошибки.Er_RFEM
MsgBox ("RFEM не открывается")
Exit Sub
Случай ошибки.Err_Model
MsgBox ("Файл не открывается!")
Случай ошибки.Err_Guideline
MsgBox ("Недоступны направляющие в файле " & model.GetName & " !")
Случай ошибок.Err_Guideline_sel
MsgBox ("Не выбраны направляющие в файле " & model.GetName & " !")
Case Else
MsgBox "Error no. : " & Err.Number & vbLf & Err.Наименование
End Select
End If
' Лицензия COM разблокирована, доступ к программе обновлен
app.UnlockLicense
Задать приложение = ничего
Set model = Nothing
Задать направляющие = ничего
End Sub
'--------------------------------------------------------------------------
' Запуск
'--------------------------------------------------------------------------
Sub init()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub
'--------------------------------------------------------------------------
' Функция для проверки, открыта ли программа RFEM
'--------------------------------------------------------------------------
Функция RFEM_open() как логическая
Размер objWMI, colPro как объект
Установить objWMI = GetObject(" winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & "." & "\root\cimv2")
Задать colPro = objWMI.Execquery_
("Select * from Win32_Process Where Name = 'RFEM64.exe'")
Если colPro.Column = 0 Тогда
RFEM_open = Ложь
Else
RFEM_open = Истина
End If
End Function
- /код#
Резюме и перспективы
В статье был представлен инструмент для перемещения/копирования направляющих в RFEM. Таким же образом может быть создан соответствующий инструмент для RSTAB. Инструмент запускается через интерфейс Excel. но его можно интегрировать также прямо в программу RFEM или RSTAB, как описано в следующей статье: