Inserir referência
Em primeiro lugar, a biblioteca de objetos do RFEM tem de ser integrada no editor VBA, selecionando "Ferramentas" › "Referências".
janelas 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.
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.
- code.py#
Opção Explicit
'http://www.dlubal.com/pt -xxx
' Fechar janela após clicar em Cancelar
'http://www.dlubal.com/pt -xxx
Sub particular cmdClose_clique()
frmLinha auxiliar.Ocultar
End Sub
'http://www.dlubal.com/pt -xxx
' Abrir procedimento para deslocar/copiar linhas auxiliares e fechar janela após clique em OK
'http://www.dlubal.com/pt -xxx
Privado Sub cmdOK_Type ()
Se txbNum.Value = "" Então
txbNumber.Value = 0
End If
Se txbX.Value = "" Então
txbX.Value = 0
End If
Se txbY.Value = "" Então
txbY.Valor = 0
End If
Se txbZ.Value = "" Então
txbZ.Value = 0
End If
Chamada de modGuideline.SetGuidelines(txbAnz.Value, txbX.Value, txbY.Value, txbZ.Value)
frmLinha auxiliar.Ocultar
End Sub
'http://www.dlubal.com/pt -xxx
' Funçáo para autorizar só casas decimais
'http://www.dlubal.com/pt -xxx
Função particular TxT_KeyDown(objTextBox As MSForms.TextBox, iKeyCode As Integer) As Integer
Selecionar iKeyCode de caso
' 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 ()
' 46 tecla Del
Caso 48 Para 57, 8, 96 Para 105, 37, 39, 46: TxT_KeyDown = iKeyCode
' Permitir só um sinal de menos na primeira posiçáo
' 109 menos (teclado numérico)
' 189 menos
Casos 109, 189:
Se InStr(1, objTextBox, "-", vbTextCompare) > 0 Ou objTextBox.SelStart <> 0 Então
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
Caso 190, 188, 110:
Se InStr(1, objTextBox, , vbTextCompare) > 0 Ou objTextBox.SelStart = 0 Então
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorar todos os outros sinais
Caso contrário: TxT_KeyDown = 0
Terminar seleção
End Function
'http://www.dlubal.com/pt -xxx
' Permitir só número decimais para a entrada da coordenada X
'http://www.dlubal.com/pt -xxx
Privado Sub txbX_KeyDown (ByVal iKeyCode como MSForms.ReturnInteger, ByVal Shift como Integer)
iKeyCode = TxT_KeyDown(txbX, CInt(iKeyCode))
End Sub
'http://www.dlubal.com/pt -xxx
' Permitir só número decimais para a entrada da coordenada Y
'http://www.dlubal.com/pt -xxx
Privado Sub txbY_KeyDown (ByVal iKeyCode como MSForms.ReturnInteger, ByVal Shift como Integer)
iKeyCode = TxT_KeyDown(txbY, CInt(iKeyCode))
End Sub
'http://www.dlubal.com/pt -xxx
' Permitir só número decimais para a entrada da coordenada Z
'http://www.dlubal.com/pt -xxx
Privado Sub txbZ_KeyDown (ByVal iKeyCode como MSForms.ReturnInteger, ByVal Shift como Integer)
iKeyCode = TxT_KeyDown(txbZ, CInt(iKeyCode))
End Sub
'http://www.dlubal.com/pt -xxx
' Permiti só números inteiros na entrada do número de cópias
'http://www.dlubal.com/pt -xxx
Privado Sub txbAnz_KeyPress(ByVal iKeyCode As MSForms.ReturnInteger)
Selecionar iKeyCode de caso
' Permitir só número de 0 a 9
Casos 48 a 57
' Ignorar todos os outros sinais
Caso contrário: iKeyCode = 0
Terminar seleção
End Sub
- /código#
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 nos comentários.
- code.py#
Opção Explicit
Erros de enumeração
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
Enumeração final
'http://www.dlubal.com/pt -xxx
' Procedimento para deslocar e copiar linhas auxiliares selecionadas
'http://www.dlubal.com/pt -xxx
Subconjunto de linhas auxiliares (iNo. Como inteiro, dNodeX, dNodeY, dNodeZ como duplo)
Dim model As RFEM5.model
Dim aplicação como RFEM5.Application
Guias de dimensão como IGuideObjects
Dim linhas() Como linha auxiliar
Dim iCountAll, iCountSel, i, iAnzCopy, iGuideNo como inteiro
Dim novaLinha de camada como linha auxiliar
No caso de erro ir para tratamento de erros
' 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
Se ap.GetModelCount > 0 Então
Definir modelo = aplicação.GetAactiveModel
Else
' Desencadear erro se nenhum modelo estiver aberto
Err.Aumentar erros.Err_Model
End If
' Obter interface para linhas auxiliares
Definir guias = model.GetGuideObjects
' Determinar número de linhas auxiliares
model.GetModelData.EnableSelections (Falso)
iCountAll = model.GetGuideObjects.GetGuidelineCount
Se iCountAll = 0, então
' Desencadear erro se não existirem linhas auxiliares
Err.Aumentar erros.Err_Guideline
End If
iGuideNo = guias.GetGuideline(iCountAll - 1, AtInindex).GetData.No
' Determinar número de linhas auxiliares selecionadas
model.GetModelData.EnableSelections (verdadeiro)
iCountSel = model.GetGuideObjects.GetGuidelineCount
Se iCountSel > 0, então
' Copiar as linhas auxiliares selecionadas
guias.PrepareModification
linhas = guias.GetGuidelines ()
Se iNúmero > 0 Então
Para iNo.Copy = 1 Para iNo
Para i = 0 Até iCountSel - 1
novoLayerLine.WorkPlane = linhas(i).WorkPlane
' Criar novo ambiente de trabalho se a linha auxiliar tiver de ser copiada para outro ambiente de trabalho
Se (linhas(i) .WorkPlane = PlaneXY e dNodeZ <> 0) Então
newLayerLine.WorkPlaneOrigin.Z = linhas(i).WorkPlaneOrigin.Z + dNodeZ * iAnzKopie
novaLayerLine.WorkPlaneOrigint.X = linhas(i).WorkPlaneOrigin.X
novoLayerLine.WorkPlaneOrigin.Y = linhas(i).WorkPlaneOrigin.Y
ElseIf (linhas(i).PlanoDePlano = PlaneYZ E dNodeX <> 0) Então
newLayerLine.WorkPlaneOrigin.X = linhas(i).WorkPlaneOrigin.X + dNodeX * iAnzKopie
novoLayerLine.WorkPlaneOrigin.Y = linhas(i).WorkPlaneOrigin.Y
novaLayerLine.WorkPlaneOrigin.Z = linhas(i).WorkPlaneOrigin.Z
ElseIf (linhas(i).WorkPlane = PlaneXZ E dNodeY <> 0) Então
newLayerLine.WorkPlaneOrigin.Y = linhas(i).WorkPlaneOrigin.Y + dNodeY * iAnzKopie
novaLayerLine.WorkPlaneOrigint.X = linhas(i).WorkPlaneOrigin.X
novaLayerLine.WorkPlaneOrigin.Z = linhas(i).WorkPlaneOrigin.Z
Else
' Linhas auxiliares no mesmo ambiente de trabalho
novaLayerLine.WorkPlaneOrigint.X = linhas(i).WorkPlaneOrigin.X
novoLayerLine.WorkPlaneOrigin.Y = linhas(i).WorkPlaneOrigin.Y
novaLayerLine.WorkPlaneOrigin.Z = linhas(i).WorkPlaneOrigin.Z
End If
novaLayerLine.Type = linhas(i).Type
novaLayerLine.Angle = linhas(i).Angle
novaCamadaLine.Radius = linhas(i).Radius
' As coordenadas das linhas auxiliares (X, Y, Z) da cópia são ajustadas pelo vetor de deslocamento
novaCamada.Ponto1.X = linhas(i).Ponto1.X + dNodeX * iAnzKopie
newLayerLine.Point1.Y = linhas(i).Point1.Y + dNodeY * iAnzKopie
novaCamada.Ponto1.Z = linhas(i).Ponto1.Z + dNodeZ * iAnzKopie
newLayerLine.Point2.X = linhas(i).Point2.X + dNodeX * iAnzKopie
newLayerLine.Point2.Y = linhas(i).Point2.Y + dNodeY * iAnzKopie
newLayerLine.Point2.Z = linhas(i).Point2.Z + dNodeZ * iAnzKopie
newLayerLine.No = iGuideNo + i + 1
newLayerLine.Description = "Copiar linha auxiliar " + CStr(lines(i).No)
guias.Definirlinha auxiliar novaCamadaLinha
Continuar
iCountAll = iCountAll + iCountSel
iGuideNo = guias.GetGuideline(iCountAll - 1, AtInindex).GetData.No
Continuar
' Deslocar linhas auxiliares selecionadas
Else
Para i = 0 Até iCountSel - 1
' Deslocar linhas auxiliares para outro ambiente de trabalho
Se (linhas(i) .WorkPlane = PlaneXY e dNodeZ <> 0) Então
linhas(i).WorkPlaneOrigin.Z = linhas(i).WorkPlaneOrigin.Z + dNodeZ
ElseIf (linhas(i).PlanoDePlano = PlaneYZ E dNodeX <> 0) Então
linhas(i).WorkPlaneOrigin.X = linhas(i).WorkPlaneOrigin.X + dNodeX
ElseIf (linhas(i).WorkPlane = PlaneXZ E dNodeY <> 0) Então
linhas(i).WorkPlaneOrigin.Y = linhas(i).WorkPlaneOrigin.Y + dNodeY
End If
' As coordenadas das linhas auxiliares (X, Y, Z) são ajustadas pelo vetor de deslocamento
linhas(i).Ponto1.X = linhas(i).Ponto1.X + dNóX
linhas(i).Ponto1.Y = linhas(i).Ponto1.Y + dNóY
linhas(i).Ponto1.Z = linhas(i).Ponto1.Z + dNóZ
linhas(i).Ponto2.X = linhas(i).Ponto2.X + dNóX
linhas(i).Ponto2.Y = linhas(i).Ponto2.Y + dNóY
linhas(i).Ponto2.Z = linhas(i).Ponto2.Z + dNóZ
Continuar
guias.DefinirLinhas de guia
End If
guias.FinishModifikation
Else
' Desencadear erro se não estiverem selecionadas linhas auxiliares
Err.Aumentar erros.Err_Guideline_sel
End If
' Gestão de erros
Tratamento de erro:
If Err.Number <> 0 Then
Selecionar caso Número de erro
Erros de caso.Err_RFEM
MsgBox ("o RFEM não está aberto")
Sair do sub
Erros de caso.Err_Model
MsgBox ("Nenhum modelo está aberto!")
Erros de caso.Err_Guideline
MsgBox ("Não existem linhas auxiliares no ficheiro " & model.GetName & " !")/code
Erros de caso.Err_Guideline_sel
MsgBox ("Nenhumas linhas auxiliares estão selecionadas no ficheiro " & model.GetName & " !")
Caso contrário
MsgBox "Erro n.º : " & Err.Number & vbLf & Err.Descrição
Terminar seleção
End If
' A licença COM está desbloqueada, o acesso ao programa é novamente possível
ap.DesbloquearLicença
Definir aplicação = nada
Set model = Nothing
Definir guias = Nada
End Sub
'http://www.dlubal.com/pt -xxx
' Inicialização
'http://www.dlubal.com/pt -xxx
Sub init()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub
'http://www.dlubal.com/pt -xxx
' Função para verificar se o RFEM está aberto
'http://www.dlubal.com/pt -xxx
Função RFEM_open() Como boleano
Dim objWMI, colPro As objeto
Definir objWMI = GetObject("winmgmts:" _
& "{impresentationLevel=impersonalizar}!\\& "." & "\raiz\cimv2")
Definir colPro = objWMI.Exec Query_
("Selecionar * de Win32_Process onde nome = 'RFEM64.exe'")
Se colPro.Count = 0 Então
RFEM_open = Falso
Else
RFEM_open = verdadeiro
End If
End Function
- /código#
Resumo e perspetivas
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. Também é possível integrar esta ferramenta no RFEM ou no RSTAB de acordo com o artigo: