Copiare tutti i Fogli di un Disegno in un nuovo Disegno

Adahm · 27 Aprile 2022

Ciao a tutti,

ho in archivio qualche migliaio di file di grosse dimensioni, perché sono stati generati da un Template "corrotto" e avrei la necessità di sistemarli.
Ho visto che copiando tutti i fogli di un file corrotto, in un file nuovo partendo da un Template "pulito", quest'ultimo ha delle dimensioni accettabili (meno di 1MB contro i 10MB del file corrotto).

Per questo motivo ho provato a scrivere una routine che possa fare questa operazione automaticamente, ma non riesco a farla funzionare. Per un po' sono riuscito a copiare i Fogli nel nuovo file, ma adesso non funziona più e non capisco in cosa sbaglio.

Qualcuno sa dirmi dove sbaglio o se il problema si può risolvere in altro modo?
Grazie

Di seguito il codice che sto cercando di far funzionare:

Codice:

Public Sub ReducingFileSize()
    ' Riduce le dimensioni dei file corrotti, copiandone i fogli in un file nuovo che sovrascriverà i file corrotti
   
    On Error GoTo Err_ReducingFileSize:
   
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    ' Se non è un file di tipo drawing esce
    If oDrawDoc.DocumentType <> kDrawingDocumentObject Then
        MsgBox "Il documento attivo non è un disegno", vbCritical, "Documento non compatibile"
        Exit Sub
    End If
   
    ' Apre un file nuovo
    Dim sStandard As String
    sStandard = "\\ap03\PrismaTech\ConfigurazioniCAD\Inventor\Templates\Standard.idw"
    Dim oNewDrawDoc As DrawingDocument
    Set oNewDrawDoc = ThisApplication.Documents.Add(kDrawingDocumentObject, sStandard, True)  ', [CreateVisible] As Boolean )
   
    ' Cicla su ogni foglio del file e li copia nel file nuovo
    Dim oSheet As sheet
    For Each oSheet In oDrawDoc.Sheets
        Call oSheet.Activate
        ' Da questa riga non riesco a farlo funzionare, il resto del codice non è testato
        Call oSheet.CopyTo(oNewDrawDoc)
    Next
   
    ' Registra il percorso e il nome del file originale
    Dim sFullFileName As String
    sFullFileName = oDrawDoc.fullFilename
   
    ' Cancella il primo Foglio
    For Each oSheet In oNewDrawDoc.Sheets
        Call oSheet.Delete
        Exit For
    Next
   
    ' Aggiorna il documento
    Call oNewDrawDoc.Update
   
    ' Chiude il file originale
    Call oDrawDoc.Close(False)
   
    ' Salva il nuovo documento sovrascrivendo il file originale
    Call oNewDrawDoc.SaveAs(sFullFileName, False)
   
Err_ReducingFileSize:
    Debug.Print Err.Description
    Resume Next
End Sub

Matteo Cappelli dis.CAD · 27 Aprile 2022

ciao
hai provato con

permette di sostituire in massa all'interno degli idw presenti in una cartella le Risorse di disegno (cartigli squadrature ecc.) copiandole da un templete "corretto"
Se i dati hanno lo stesso nome , sostituisce il contenuto nel file "errato"
non so se ti può essere utile nel tuo caso

Adahm · 27 Aprile 2022

Ciao Matteo,
cartigli, squadrature, ecc... sono corretti, è il file ad essere corrotto.
L'unico modo che ho trovato per sistemare il tutto, è stato quello di copiare i Fogli in un file nuovo, perciò il codice.

Catafratto · 27 Aprile 2022

A dirti il vero mi pare funzioni benissimo (grazie per il codice, a questo punto!)

Ho fatto un paio di ritocchi per seguire meglio il funzionamento, ma appunto funziona

Le mie modifiche per provare:
- ho aggiunto un paio di MsgBox per vedere a che punto si blocca;
- Invece del ciclo for per eliminare il primo foglio sono andato con accesso diretto;
- ho modificato il nome del file di destinazione per non pasticciare con i nomi che poi non mi capivo più.

Che errore ti da?

Codice:

Public Sub ReducingFileSize()
    ' Riduce le dimensioni dei file corrotti, copiandone i fogli in un file nuovo che sovrascriverà i file corrotti
   
    On Error GoTo Err_ReducingFileSize:
   
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    ' Se non è un file di tipo drawing esce
    If oDrawDoc.DocumentType <> kDrawingDocumentObject Then
        MsgBox "Il documento attivo non è un disegno", vbCritical, "Documento non compatibile"
        Exit Sub
    End If
   
    ' Apre un file nuovo
    Dim sStandard As String
    sStandard = "\\ap03\PrismaTech\ConfigurazioniCAD\Inventor\Templates\Standard.idw"
    Dim oNewDrawDoc As DrawingDocument
    Set oNewDrawDoc = ThisApplication.Documents.Add(kDrawingDocumentObject, sStandard, True)  ', [CreateVisible] As Boolean )
    MsgBox "nuova tavola"
    ' Cicla su ogni foglio del file e li copia nel file nuovo
    Dim oSheet As Sheet
    For Each oSheet In oDrawDoc.Sheets
        Call oSheet.Activate
        MsgBox oSheet.Name
        ' Da questa riga non riesco a farlo funzionare, il resto del codice non è testato
        Call oSheet.CopyTo(oNewDrawDoc)
    Next
   
    ' Registra il percorso e il nome del file originale
    Dim sFullFileName As String
    sFullFileName = oDrawDoc.FullFileName
    sFullFileName = Strings.Replace(sFullFileName, oDrawDoc.DisplayName, "Nuovo_" & oDrawDoc.DisplayName)
    ' Cancella il primo Foglio
    oNewDrawDoc.Sheets.Item(1).Delete
    'For Each oSheet In oNewDrawDoc.Sheets
    '    Call oSheet.Delete
    '    Exit For
    'Next
   
    ' Aggiorna il documento
    Call oNewDrawDoc.update
   
    ' Chiude il file originale
    Call oDrawDoc.Close(False)
   
    ' Salva il nuovo documento sovrascrivendo il file originale
    Call oNewDrawDoc.SaveAs(sFullFileName, False)
   
Err_ReducingFileSize:
    Debug.Print Err.Description
    Resume Next
End Sub

Catafratto · 27 Aprile 2022

La butto lì: non è che hai Vault e i file da sovrascrivere sono in sola lettura?

Adahm · 27 Aprile 2022

Ciao Catafratto,
ho capito dove era il problema. In pratica nei file che devo sistemare ci sono dei cartigli vecchi, che includono delle immagini, di conseguenza il comando di copia non funziona solo in quelle circostanze.
Per risolvere cancello il cartiglio prima di copiare il Foglio.

PS: Grazie per la riga di comando per eliminare il primo Foglio. Non mettevo la "s" in "Sheet" nella riga oNewDrawDoc.Sheets.Item(1).Delete, perciò avevo ciclato.

Adahm · 27 Aprile 2022

Catafratto ha detto:
La butto lì: non è che hai Vault e i file da sovrascrivere sono in sola lettura?

Sì, ho Vault, ma li estraggo, eseguo la macro e li archivio.
Così funziona.
Tu sai se si può fare l'operazione direttamente in Vault?
Non ho mai scritto codice in Vault.

Catafratto · 27 Aprile 2022

Non so, mai usato Vault e non so quanto sia gestibile via VBA...

Adahm · 27 Aprile 2022

Mi pare che si possa gestire solo con C# o C++, non in VBA.
Per questo non sono felicissimo

Adahm · 28 Aprile 2022

Riprendo la discussione per un approfondimento.
Sempre nella procedura sopra descritta, nei comandi di:
- Chiusura file (senza salvare)
- Salvataggio file
Bisogna sempre confermare con Sì o No o quel che serve.
Qualcuno sa se è possibile specificare nelle righe di comando se salvare o meno, senza far uscire le finestre di conferma?

Catafratto · 28 Aprile 2022

Per disabilitare i prompt dovrebbe essere questa:
ThisApplication.SilentOperation = True

Adahm · 28 Aprile 2022

Perfetto, grazie Catafratto!
Dall'help in linea, pensavo che il (false) nel comando .close(false) non mi chiedesse di salvare, ma evidentemente serve a qualche cosa d'altro. Tu sai a cosa?

Catafratto · 28 Aprile 2022

Questo quello che so / ho capito

Document.Close( [SkipSave] As Boolean )
.close(true) -> chiude senza salvare
.close(false) -> salva e chiude
ThisApplication.SilentOperation = False -> esce la finestrella di dialogo
ThisApplication.SilentOperation = True -> salva direttamente senza chiedere conferma

Adahm · 28 Aprile 2022

Grazie Catafratto!

Copiare tutti i Fogli di un Disegno in un nuovo Disegno

Adahm

Utente standard

Matteo Cappelli dis.CAD

Utente Standard

Adahm

Utente standard

Catafratto

Utente Standard

Catafratto

Utente Standard

Adahm

Utente standard

Adahm

Utente standard

Catafratto

Utente Standard

Adahm

Utente standard

Adahm

Utente standard

Catafratto

Utente Standard

Adahm

Utente standard

Catafratto

Utente Standard

Adahm

Utente standard

Discussioni simili

Utenti online

Statistiche forum