Interfaz COM en VBA | 5. Crear una herramienta para copiar y mover líneas auxiliares

Inserción del enlace

El objeto de la biblioteca de RFEM tiene que estar integrado primero en el editor de VBA señalando "Herramientas" → "Referencias".

Integración del tipo de b¡blioteca Dlubal RFEM

Tabla de entrada

El vector de desplazamiento, así como también el número de copias, tendrían que introducirse en la tabla de entrada. Para crear la tabla de entrada, se generará un formulario de usuario señalando "Insertar" -> "UserForm" en el editor de VBA. Los controles necesarios serán ubicados en el formulario de usuario. Para este objetivo, el control respectivo tiene que seleccionarse en la caja de herramientas y luego guardarse en el formulario de usuario. Las propiedades tales como el tamaño, posición, nombre del formulario de usuario y los controles pueden definirse en la ventana de propiedades.

Ventana de datos de entrada

Para el vector de desplazamiento sólo se permiten como datos de entrada decimales y para el número de copias números enteros. La fuente del código de la tabla de datos de entrada está indicada a continuación:

Opción explícita

'------------------------------------------------- -------------------------
' Cierra la ventana al hacer clic en Cancelar
'------------------------------------------------- -------------------------
Sub privado cmdClose_Click ()
frmGuideline.Hide
End Sub

'------------------------------------------------- -------------------------
' Procedimiento de apertura para mover/copiar las líneas auxiliares y cerrar la ventana la hacer clic en Aceptar
'------------------------------------------------- -------------------------
Sub privado cmdOK_Click ()
If txbAnz.Value = "" Entonces
txbAnz.Value =

Ventana de datos de entrada

'------------------------------------------------- -------------------------
' Función para permitir sólo decimales
'------------------------------------------------- -------------------------
Función privada TxT_KeyDown (objTextBox Is MSForms.TextBox, iKeyCode Como entero)Como entero
Seleccionar caso iKeyCode
' Permitir los signos siguientes:
' 8 tecla de retroceso para corregir
' 48-57 números de 0 a 9
' 96-105 números de 0 a 9 (teclado numérico)
' 37, 39 tecla del cursor ()
' 46 tecla Supr
Caso 48 To 57,8,96 To 105,37,39,46: TxT_KeyDown = iKeyCode
' Permitir sólo un signo menos en la primera posición
' 109 menos (teclado numérico)
' 189 menos
Caso 109,189:
If InStr (1, objTextBox, "-", vbTextCompare)> 0 O objTextBox.SelStart <> 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 109
End If
' Permitir sólo una coma o punto y reemplazar punto por coma
' 188 Coma
' 110 Coma (bloque numérico)
' 190 Punto
Caso 190,188,110:
If InStr (1, objTextBox, ",", vbTextCompare)> 0 O bien objTextBox.SelStart = 0 Then
TxT_KeyDown = 0
Else
TxT_KeyDown = 188
End If
' Ignorar todos los signos
Caso diferente: TxT_KeyDown = 0
Selección final
End Function

'------------------------------------------------- -------------------------
' Permitir sólo decimales para introducir la coordenada X
'------------------------------------------------- -------------------------
Sub privado txbX_KeyDown (ByVal iKeyCode como MSForms.ReturnInteger, ByVal Shift como Integer)
iKeyCode = TxT_KeyDown (txbX, CInt (iKeyCode))
End Sub

'------------------------------------------------- -------------------------
' Permitir sólo decimales para introducir la coordenada Y
'------------------------------------------------- -------------------------
Private Sub txbY_KeyDown (ByVal iKeyCode Is MSForms.ReturnInteger, ByVal DesplazamientoComo entero)
iKeyCode = TxT_KeyDown (txbY, CInt(iKeyCode))
End Sub

'------------------------------------------------- -------------------------
' Permitir sólo decimales para introducir la coordenada Z
'------------------------------------------------- -------------------------
Sub privado txbZ_KeyDown (ByVal iKeyCode Is MSForms.ReturnInteger, ByVal DesplazamientoComo entero)
iKeyCode = TxT_KeyDown (txbZ, CInt(iKeyCode))
End Sub

'------------------------------------------------- -------------------------
' Sólo permitir números enteros para introducir el número de copias
'------------------------------------------------- -------------------------
Sub privado txbAnz_KeyPress (ByVal iKeyCode Is MSForms.ReturnInteger)
Seleccionar caso iKeyCode
' Permitir sólo números de 0-9
Caso 48 To 57
' Ignorar todos los signos
Caso diferente: iKeyCode = 0
Selección final
End Sub

Movimiento y copia de líneas auxiliares

El código fuente para mover y copiar las líneas auxiliares se lista a continuación. Los pasos individuales se explican en los comentarios.

Opción explícita

Enumeración Errores y advertencias
Err_RFEM = 513 "RFEM no está abierto
Err_Model = 514 "No hay ningún modelo abierto
Err_Guideline = 515 'No hay pautas disponibles
Err_Guideline_sel = 516 'No se han seleccionado líneas auxiliares
Fin de enumeración

'------------------------------------------------- -------------------------
' Procedimiento para mover y copiar las líneas auxiliares seleccionadas
'------------------------------------------------- -------------------------
Sub SetGuidelines (iAnz Como entero, dNodeX, dNodeY, dNodeZ Como doble)
Dim modelo Is RFEM5.model
Dim aplicación Is RFEM5.Application
Dim guías Is IGuideObjects
Dim líneas () Is Línea auxiliar
Dim iCountAll, iCountSel, i, iAnzKopie, iGuideNo Como entero
Dim newLayerLine Is Línea auxiliar

On Error GoTo ErrorHandler

' Conseguir interfaz con RFEM
If RFEM_open = Cierto entonces
Conjunto app = GetObject (, "RFEM5.Application")
Else
' Lanzar error si RFEM no está abierto
Err.Raise Errors.Err_RFEM
End If

' Bloquear la licencia de COM y programar acceso
app.LockLicense

' Conseguir interfaz para el modelo activo
If app.GetModelCount> 0 Then
Conjunto model = app.GetActiveModel
Else
' Lanzar error si no está abierto el modelo
Err.Raise errores.Err_Model
End If

' Conseguir interfaz para líneas auxiliares
Conjunto guides = model.GetGuideObjects

' Definir números para líneas auxiliares
model.GetModelData.EnableSelections (Falso)
iCountAll = model.GetGuideObjects.GetGuidelineCount
If iCountAll = 0 Then
' Lanzar error si no hay líneas auxiliares disponibles
Err.Raise errores.Err_Guideline
End If
iGuideNo = guides.GetGuideline (iCountAll - 1, AtIndex) .GetData.No

' Definir números de las líneas seleccionadas
model.GetModelData.EnableSelections (Verdadero)
iCountSel = model.GetGuideObjects.GetGuidelineCount

If iCountSel> 0 Then
' Copiar líneas seleccionadas
guías.PrepararModificación
líneas = guías.GetGuidelines ()
If iAnz> 0 Then
Para iAnzKopie = 1 To iAnz
Para i = 0 To iCountSel - 1
newLayerLine.WorkPlane = líneas (i) .WorkPlane
' Crear un plano de trabajo nuevo si la línea auxiliar debería copiarse a otro plano de trabajo
If (líneas (i) .WorkPlane = PlaneXY Y dNodeZ <>

Ventana de datos de entrada

End Sub

'------------------------------------------------- -------------------------
' Inicialización
'------------------------------------------------- -------------------------
Sub init ()
frmGuideline.txbX.Value = "0"
frmGuideline.txbY.Value = "0"
frmGuideline.txbZ.Value = "0"
frmGuideline.txbAnz.Value = "0"
End Sub

'------------------------------------------------- -------------------------
' Función para comprobar si RFEM está abierto
'------------------------------------------------- -------------------------
Capacidades RFEM_open () Como booleano
Dim objWMI, colPro Como objeto

Conjunto objWMI = GetObject ("winmgmts:" _
& "{impersonationLevel = suplantar}! \\" & "." & "\ root \ cimv2")
Conjunto colPro = objWMI.ExecQuery _
("Seleccione * de Win32_Process donde Name = 'RFEM64.exe'")
If colPro.Count = 0 Then
RFEM_open = Falso
Else
RFEM_open = Verdadero
End If
End Function

Resumen y vista general

En este artículo se ha desarrollado una herramienta para mover o copiar líneas auxiliares en RFEM. De la misma manera, se puede crear la herramienta correspondiente para RSTAB. La herramienta se inicia por medio de la interfaz de Excel. También es posible integrar esta herramienta en RFEM o RSTAB como se describe en este artículo.