- Marcar como nuevo
- Favorito
- Suscribir
- Silenciar
- Suscribirse a un feed RSS
- Resaltar
- Imprimir
- Denunciar
Buenos dias,
Tenemos creada una regla VBA para guardar los desarrollos DXF.
Esta regla por defecto nos guarda el archivo DXF en la carpeta donde se encuentre el .IPT
Nos gustaría que al ejecutar la Macro VBA nos preguntara en que carpeta queremos grabar el archivo (mediante una ventana como la que aparece al dar a "Guardar como...").
Adjunto el código:
'INICIO CONFIGURACION
Sub Guardar_DXF()
Dim Opcion As String
Dim oDoc As PartDocument
Set oDoc = ThisApplication.ActiveDocument
Dim oCompDef As SheetMetalComponentDefinition
Set oCompDef = oDoc.ComponentDefinition
Set fs = CreateObject("Scripting.FileSystemObject")
Set oUOM = oDoc.UnitsOfMeasure
UnidadesAngulos = oUOM.GetStringFromType(oUOM.AngleUnits)
'Actualizar pieza y desarrollo
oDoc.Rebuild2
'FINAL CONFIGURACION
'INICIO DEL PROGRAMA
Linea0:
'Comprobar si el archivo esta guardado (si no lo esta, preguntar)
If fs.FileExists(oDoc.FullFileName) Then
'Si esta guardado...
GoTo Linea10
Else
'Si no esta guardado...
GoTo Linea100
End If
Linea10:
'Segunda comprobacion de si esta guardao (si no lo esta, finalizar)
If fs.FileExists(oDoc.FullFileName) Then
'Si esta guardado...
GoTo Linea15
Else
'Si no esta guardado...
Dim Mensaje9, Estilo9, Título9
Mensaje9 = "Imposible guardar el documento." ' Define el mensaje.
Estilo9 = vbCritical + vbOKOnly ' Define los botones.
Título9 = "Error al guardar el documento" ' Define el título.
MensageGuardar = MsgBox(Mensaje9, Estilo9, Título9)
GoTo Linea999
End If
Linea15:
' Coger el nombre entero del archivo (Get document's full file name)
Dim sFname As String
sFname = oDoc.FullFileName
' El formato del archivo depende de la extension (The file format will depend on the extension)
' Configurar la extension a .DXF (Set file name extension to ".DXF")
sFname = Left$(sFname, Len(sFname) - 3) & "dxf"
'Comprobar si el DXF existe
If fs.FileExists(sFname) Then
'Si existe...
GoTo Linea200
Else
'Si no existe...
GoTo Linea20
End If
Linea20:
'Comprobacion si las unidades GRADOS
CompUnidadesAngulos = "grado"
If UnidadesAngulos = CompUnidadesAngulos Then
'Las unidades son GRADOS
GoTo Linea400
Else
'Las unidades NO son GRADOS
Dim Mensaje4, Estilo4, Título4
Mensaje4 = "Los parámetros de unidad del documento no estan configurados como Grados." ' Define el mensaje.
Estilo4 = vbCritical + vbOKOnly ' Define los botones.
Título4 = "Unidades de angulo erroneas" ' Define el título.
MensageUnidades = MsgBox(Mensaje4, Estilo4, Título4)
'Pregunta si queremos cambiarlo
Dim Mensaje5, Estilo5, Título5
Mensaje5 = "Desea modificar los parámetros de unidades a Grado?" ' Define el mensaje.
Estilo5 = vbYesNo + vbDefaultButton1 + vbQuestion ' Define los botones.
Título5 = "Modificar unidades a Grado" ' Define el título.
MensageUnidades2 = MsgBox(Mensaje5, Estilo5, Título5)
If MensageUnidades2 = vbYes Then ' El usuario eligió el botón Sí.
'Si elige cambiarlo...
GoTo Linea300
Else
'Si no elige cambiarlo...
GoTo Linea999
End If
GoTo Linea999
End If
Linea30:
'Segunda comprobacion si las unidades
If UnidadesAngulos = CompUnidadesAngulos Then
'Si son grados...
GoTo Linea400
Else
'Si no lo son...
Dim Mensaje8, Estilo8, Título8
Mensaje8 = "Imposible modificar las unidades a Grados." ' Define el mensaje.
Estilo8 = vbCritical + vbOKOnly ' Define los botones.
Título8 = "Error al modificar las unidades" ' Define el título.
MensageCambio = MsgBox(Mensaje8, Estilo8, Título8)
GoTo Linea999
End If
Linea40:
'Comprobacion de si hay desarollo
If oCompDef.HasFlatPattern = True Then
'Si lo hay...
GoTo Linea50
Else
'Si no lo hay...
Dim Mensaje3, Estilo3, Título3
Mensaje3 = "No se ha podido guardar DXF. Falta desarrollo." ' Define el mensaje.
Estilo3 = vbCritical + vbOKOnly ' Define los botones.
Título3 = "Error al guardar desarrollo" ' Define el título.
MensageDesarrollo = MsgBox(Mensaje3, Estilo3, Título3)
Dim Mensaje6, Estilo6, Título6
Mensaje6 = "Desarrollar pieza para guardar DXF." ' Define el mensaje.
Estilo6 = vbCritical + vbOKOnly ' Define los botones.
Título6 = "Desarrollar pieza" ' Define el título.
MensageDesarrollo2 = MsgBox(Mensaje6, Estilo6, Título6)
GoTo Linea999
End If
Linea50:
'Comprobacion si existe iProperty "Anotaciones de desarrollo"
' Obtener configuracion de iProperty
Dim customPropSet As PropertySet
Set customPropSet = oDoc.PropertySets.Item("Inventor User Defined Properties")
' Obtener la iPropierty "Anotacionde de Desarrollo"
Dim customProp As Property
On Error GoTo Linea60
Set customProp = customPropSet.Item("Anotaciones de Desarrollo")
On Error GoTo 0
'Comprobar si las anotaciones estan en blanco
If customProp.value = "0" Or customProp.value = "" Or customProp.value = " " Or customProp.value = "-" Then
GoTo Linea60
Else
GoTo Linea65
End If
Linea60:
'Grabado de DXF con opciones
Opcion = "FLAT PATTERN DXF?AcadVersion=2004&TangentLayer=1&ToolCenterUpLayer=2&ToolCenterDownLayer=3&ArcCentersLayer=4&OuterProfileLayer=CONTORNO_EXTERIOR&InteriorProfilesLayer=CONTORNO_INTERIOR&BendUpLayer=PLEGADO_ARRIBA&BendDownLayer=PLEGADO_ABAJO&FeatureProfilesUpLayer=EMBUTICION_ARRIBA&FeatureProfilesDownLayer=EMBUTICION_ABAJO&AltRepFrontLayer=REPRESENTACION_ALTERNATICA_ARRIBA&AltRepBackLayer=REPRESENTACION_ALTERNATIVA_ABAJO&TangentRollLinesLayer=LINEAS_DE_CURVA_TANGENTE&RollLinesLayer=LINEAS_DE_CURVA&BendUpLayerColor=255;255;0&BendDownLayerColor=255;255;0&FeatureProfilesUpLayerColor=0;255;0&FeatureProfilesDownLayerColor=0;0;255&30AltRepBackLayerColor=255;0;0&TangentRollLinesLayerColor=255;128;0&RollLinesLayerColor=255;128;0&SimplifySplines=False&BendDownLayerLineType=37634&AltRepBackLayerLineType=37634&AdvancedLegacyExport=false&ExportUnconsumedSketchProperties=False&InvisibleLayers=1;2;3;4"
oCompDef.DataIO.WriteDataToFile Opcion, sFname
MsgBox ("DXF guardado correctamente.")
GoTo Linea999
Linea65:
'Mostrar mensaje con anotaciones
Dim Mensaje12, Estilo12, Título12
Mensaje12 = "La pieza contiene Anotaciones de desarrollo:" & vbCrLf & vbCrLf ' Define el mensaje.
Mensaje12 = Mensaje12 & customProp.value & vbCrLf
Mensaje12 = Mensaje12 & vbCrLf
Mensaje12 = Mensaje12 & "Desea continuar Guardando DXF?"
Estilo12 = vbYesNo + vbDefaultButton2 + vbQuestion ' Define los botones.
Título12 = "Anotaciones de Desarrollo" ' Define el título.
MensageAnotaciones = MsgBox(Mensaje12, Estilo12, Título12)
If MensageAnotaciones = vbYes Then ' El usuario eligió el botón Sí.
'Si elige continuar guardando...
GoTo Linea60
Else
'Si elige no guardar...
NoGuardar = MsgBox("No se ha guardado el desarrollo", vbCritical + vbOKOnly, "DXF no guardado")
GoTo Linea999
End If
Linea100:
'Subprograma comprobacion de guardado (archivo pieza .IPT)
Dim Mensaje, Estilo, Título, Respuesta
Mensaje = "Debe guardar antes de seguir. ¿Desea guardar?" ' Define el mensaje.
Estilo = vbYesNo + vbDefaultButton1 + vbQuestion ' Define los botones.
Título = "Documento no guardado." ' Define el título.
RespuestaGuardar = MsgBox(Mensaje, Estilo, Título)
If RespuestaGuardar = vbYes Then ' El usuario eligió el botón Sí.
'Si elige guardarlo...
oDoc.Save
GoTo Linea10
Else
'Si no elige guardarlo...
GoTo Linea999
End If
Linea200:
'Subprograma de comprobacion sobreescribir DXF
Dim Mensaje2, Estilo2, Título2, Respuesta2
Mensaje2 = "El archivo DXF ya existe. ¿Desea sobreescribir?" ' Define el mensaje.
Estilo2 = vbYesNo + vbDefaultButton1 + vbExclamation ' Define los botones.
Título2 = "El archivo DXF ya existe." ' Define el título.
RespuestaSobreescribir = MsgBox(Mensaje2, Estilo2, Título2)
If RespuestaSobreescribir = vbYes Then ' El usuario eligió el botón Sí.
'Si elige SI sobreescribir...
GoTo Linea20
Else
'Si elige NO sobreescribir...
GoTo Linea999
End If
Linea300:
'Subprograma para modificar unidades a Grados
'Modificar unidades a Grados
oDoc.UnitsOfMeasure.AngleUnits = kDegreeAngleUnits
'Actualizar pieza y desarrollo
oDoc.Rebuild2
'Actualizar valor UnidadesAngulos
UnidadesAngulos = oUOM.GetStringFromType(oUOM.AngleUnits)
'MsgBox (UnidadesAngulos)
GoTo Linea30
Linea400:
'Subprograma comprovacion radio de plegado
' Importar parametros pieza activa.
Dim oParameters As Parameters
Set oParameters = ThisApplication.ActiveDocument.ComponentDefinition.Parameters
' Importar parametro "Radio_pliegue".
Set oSheetMetalCompDef = oDoc.ComponentDefinition
oRadioPliegue = oSheetMetalCompDef.ActiveSheetMetalStyle.BendRadius
'MsgBox (oRadioPliegue)
'Comprobacion radio de plegado modificado (predefinido R999)
If oRadioPliegue = "999" Then
'Si NO se ha modificado (R999)
Dim Mensaje10, Estilo10, Título10
Mensaje10 = "No se ha modificado el radio de plegado" ' Define el mensaje.
Estilo10 = vbCritical + vbOKOnly ' Define los botones.
Título10 = "Radio de plegado no modificado" ' Define el título.
MensageRadio = MsgBox(Mensaje10, Estilo10, Título10)
Dim Mensaje11, Estilo11, Título11
Mensaje11 = "Modificar radio antes de guardar DXF" ' Define el mensaje.
Estilo11 = vbCritical + vbOKOnly ' Define los botones.
Título11 = "Modificar radio" ' Define el título.
MensageRadio = MsgBox(Mensaje11, Estilo11, Título11)
GoTo Linea999
Else
'Si SI se ha modificado (Rx)
GoTo Linea40
End If
Linea999:
End Sub
'FIN DEL PROGRAMA
Nota: el código contiene comprobaciones adicionales sobre otras Macro VBA
Gracias
¡Resuelto! Ir a solución.
