Interface COM em VBA | 5. Criação de uma ferramenta para copiar e deslocar linhas auxiliares

Artigo técnico

RF-COM/RS-COM é uma interface programável, através da qual o RFEM/RSTAB pode ser adaptado às necessidades dos utilizadores, acrescentando macros de entrada e programas de pós-processamento personalizados. Neste artigo é desenvolvida uma ferramenta para copiar e deslocar de linhas auxiliares selecionadas no RFEM. As linhas auxiliares selecionadas podem também ser copiadas ou deslocadas para outro plano de trabalho. Como ambiente de programação é utilizado o VBA in Excel.

Inserir ligação

Em primeiro lugar, a biblioteca de objetos do RFEM tem de ser integrada no editor VBA, selecionando "Ferramentas" › "Referências".

Imagem 01 - Integrar Dlubal RFEM Type Library

Tabela de entrada

Na tabela de entrada devem ser introduzidos o vetor de deslocamento assim como o número de cópias. No editor VBA, para criar uma tabela de entrada é gerado um Userform clicando em "Inserir" - "UserForm". Depois, os comandos necessários são colocados no Userform. Para tal, os comandos desejados são selecionados na caixa de ferramentas e depois inseridos no Userform. As propriedades tais como a altura, a posição e o nome do Userform e os comandos podem ser definidos na janela de propriedades.

Imagem 02 - Tabela de entrada

Para o vetor de deslocamento, só devem ser permitidas casas decimais e para o número de cópias, só números inteiros. O texto original da tabela de entrada está listado em baixo.

Opção Explicit

'--------------------------------------------------------------------------
' Fechar janela após clicar em Cancelar
'--------------------------------------------------------------------------
Private Sub cmdClose_Click()
frmGuideline.Hide
End Sub

'--------------------------------------------------------------------------
' Abrir procedimento para deslocar/copiar linhas auxiliares e fechar janela após clique em 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

'--------------------------------------------------------------------------
' Funçáo para autorizar só casas decimais
'--------------------------------------------------------------------------
Private Function TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Select Case iKeyCode
' Permitir os seguintes sinais:
' 8 tecla de retrocesso para corrigir
' 48-57 números de 0 a 9
' 96-105 números de 0 a 9 (teclado numérico)
' teclas do cursos (<- e ->)
' 46 tecla Del
Case 48 To 57, 8, 96 To 105, 37, 39, 46: TxT_KeyDown = iKeyCode
' Permitir só um sinal de menos na primeira posiçáo
' 109 menos (teclado numérico)
' 189 menos
Case 109, 189:
If InStr(1, objTextBox, "-", vbTextCompare) > 0 Or objTextBox.SelStart <> 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 109
End If
' Permitir só uma vírgula ou um ponto e substituir pontos por vírgulas
' 188 vírgula
' 110 vírgula (teclado numérico)
' 190 ponto
Case 190, 188, 110:
If InStr(1, objTextBox, ",", vbTextCompare) > 0 Or objTextBox.SelStart = 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorar todos os outros sinais
Case Else: TxT_KeyDown = 0
End Select
End Function

'--------------------------------------------------------------------------
' Permitir só número decimais para a entrada da coordenada X
'--------------------------------------------------------------------------
Private Sub txbX_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Permitir só número decimais para a entrada da coordenada Y
'--------------------------------------------------------------------------
Private Sub txbY_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Permitir só número decimais para a entrada da coordenada Z
'--------------------------------------------------------------------------
Private Sub txbZ_KeyDown(ByVal iKeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub

'--------------------------------------------------------------------------
' Permiti só números inteiros na entrada do número de cópias
'--------------------------------------------------------------------------
Private Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
Select Case iKeyCode
' Permitir só número de 0 a 9
Case 48 To 57
' Ignorar todos os outros sinais
Case Else: iKeyCode = 0
End Select
End Sub

Deslocar e copiar as linhas auxiliares

O texto original para deslocar e copiar as linhas auxiliares selecionadas é mostrado a seguir. Os passos individuais são explicados em comentários.

Option Explicit

Enum Errors
Err_RFEM = 513 ' O RFEM não está aberto
Err_Model = 514 ' Nenhum modelo está aberto
Err_Guideline = 515 ' Não existem linhas auxiliares
Err_Guideline_sel = 516 ' Nenhumas linhas auxiliares estão selecionadas
End Enum

'--------------------------------------------------------------------------
' Procedimento para deslocar e copiar linhas auxiliares selecionadas
'--------------------------------------------------------------------------
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

' Obter interface para o RFEM
If RFEM_open = True Then
Set app = GetObject(, "RFEM5.Application")
Else
' Desencadear erro se o RFEM não estiver aberto
Err.Raise Errors.Err_RFEM
End If

' Bloquear licença COM e acesso ao programa
app.LockLicense

' Obter interface para modelo ativo
If app.GetModelCount > 0 Then
Set model = app.GetActiveModel
Else
' Desencadear erro se nenhum modelo estiver aberto
Err.Raise Errors.Err_Model
End If

' Obter interface para linhas auxiliares
Set guides = model.GetGuideObjects

' Determinar número de linhas auxiliares
model.GetModelData.EnableSelections (False)
iCountAll = model.GetGuideObjects.GetGuidelineCount
If iCountAll = 0 Then
' Desencadear erro se não existirem linhas auxiliares
Err.Raise Errors.Err_Guideline
End If
iGuideNo = guides.GetGuideline(iCountAll - 1, AtIndex).GetData.No

' Determinar número de linhas auxiliares selecionadas
model.GetModelData.EnableSelections (True)
iCountSel = model.GetGuideObjects.GetGuidelineCount

If iCountSel > 0 Then
' Copiar as linhas auxiliares selecionadas
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
' Criar novo ambiente de trabalho se a linha auxiliar tiver de ser copiada para outro ambiente de trabalho
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
' Linhas auxiliares no mesmo ambiente de trabalho
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
' As coordenadas de linhas auxiliares (X, Y, Z) da cópia são ajustadas com o vetor de deslocamento
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
' Deslocar linhas auxiliares selecionadas
Else
For i = 0 To iCountSel - 1
' Deslocar linhas auxiliares para outro ambiente de trabalho
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
' As coordenadas de linhas auxiliares (X, Y, Z) são ajustadas com o vetor de deslocamento
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
' Desencadear erro se não estiverem selecionadas linhas auxiliares
Err.Raise Errors.Err_Guideline_sel
End If

' Gestão de erros
ErrorHandler:
If Err.Number <> 0 Then
Select Case Err.Number
Case Errors.Err_RFEM
MsgBox ("o RFEM não está aberto")
Exit Sub
Case Errors.Err_Model
MsgBox ("Nenhum modelo está aberto!")
Case Errors.Err_Guideline
MsgBox ("Não existem linhas auxiliares no ficheiro " & model.GetName & " !")/code>
Case Errors.Err_Guideline_sel
MsgBox ("Nenhumas linhas auxiliares estão selecionadas no ficheiro " & model.GetName & " !")
Case Else
MsgBox "Error-Nr. : " & Err.Number & vbLf & Err.Description
End Select
End If
' A licença COM está desbloqueada, o acesso ao programa é novamente possível
app.UnlockLicense

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

End Sub

'--------------------------------------------------------------------------
' Inicialização
'--------------------------------------------------------------------------
Sub init()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub

'--------------------------------------------------------------------------
' Função para verificar se o RFEM está aberto
'--------------------------------------------------------------------------
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

Resumo e perspetiva

No artigo foi desenvolvida uma ferramenta para deslocar/copiar linhas auxiliares no RFEM. Da mesma maneira, seria possível criar uma ferramenta identica no RSTAB. A ferramenta é iniciada através da interface de utilizador do Excel. Esta ferramenta pode também ser integrada na interface de utilizador do RFEM ou do RSTAB, como descrito neste artigo.

Ligações

Contacto

Contacto da Dlubal

Tem alguma questão ou necessita de ajuda? Então entre em contacto connosco ou consulte as perguntas mais frequentes (FAQ).

+49 9673 9203 0

(falamos português)

info@dlubal.com

RFEM Programa principal
RFEM 5.xx

Programa principal

Software de engenharia estrutural para análises de elementos finitos (AEF) de estruturas planas e espaciais constituídas por lajes, paredes, vigas, sólidos e elementos de contacto

Preço de primeira licença
3.540,00 USD
RSTAB Programa principal
RSTAB 8.xx

Programa principal

Software de engenharia para o dimensionamento de estruturas reticuladas de pórticos, barras e treliças, com cálculos lineares e não-lineares de esforços internos, deformações e reações de apoio

Preço de primeira licença
2.550,00 USD
RFEM Outros
RF-COM 5.xx

Módulo adicional

Interface programável (API) com base na tecnologia COM

Preço de primeira licença
580,00 USD