Codice VBA per trattamento di archivi Open XML
In quel che segue sono riportati diversi snippet (in gergo programmatorio: brani di codice) a supporto dei lettori del mio ultimo libro sul tema OOXML, Office Open XML, il nuovo formato dei file Word, Excel, nonché PowerPoint 2007. Si tratta oggi di uno standard ufficiale ISO (International Standard Organization).
Comunque chi vuol saperne di più non ha che da… acquistare tale libro (titolo provvisorio):
Laboratorio Office XML – Edizioni FAG, Milano
(oltre che leggere altri miei contributi sul tema in questo stesso blog)
Routine di Estrazione e ripristino file OOXML
La prima routine si trova nel Capitolo 1, dotata di argomenti Target e CartDestin riferiti al file Word, Excel o PowerPoint 2007, bersaglio del trattamento estrattivo e, rispettivamente, alla cartella destinataria.
Sub ZippaFileOOXLMEstraiInCart(Target As String, CartDestin As String)
Dim OggShell As Object, Estens As String, ZipTarget As String
'Controllo essenziale sul formato file
If Left(Right(Target, 5), 1) <> "." Then
MsgBox "Formato file non valido..."
Exit Sub
End If
'Cambia l'estensione del target in zip
Estens = Right(Target, 4)
ZipTarget = Replace(Target, Estens, "zip")
'Tacita le proteste sul cambio estensione
Application.DisplayAlerts = False
'Rinomina il target come file zip
Name Target As ZipTarget
Set OggShell = CreateObject("Shell.Application")
'Incredibile a dirsi: senza "" & nell'argomento 'di Namespace si ha ERRORE!!!
'Controlla il numero di elementi di ZipTarget (solo per debug)
MsgBox "Numero item: " & OggShell.Namespace("" & ZipTarget).Items.Count
For Each oF In OggShell.Namespace("" & ZipTarget).Items
OggShell.Namespace("" & CartDestin).Copyhere (oF)
Debug.Print oF 'Solo per debug, cancellare in seguito
Next oF
Set OggShell = Nothing
'Rinomina il file zip come l'originario Target
Name ZipTarget As Target
End Sub
Il cuore della Sub può interessare altre situazioni, per cui la traduciamo in una procedura non mirata a file OOXML o ODF:
Sub EstraiDaZipFile(ZipFile As String, CartDestin As String)
Dim OggShell As Object, oF As Object
'Controllo sull’estensione zip
If Right(ZipFile, 3) <> "zip" Then
"MsgBox "Occorre un file con estensione ZIP!"
Exit Sub
End If
Set OggShell = CreateObject("Shell.Application")
For Each oF In OggShell.Namespace("" & ZipFile).Items
OggShell.Namespace("" & CartDestin).Copyhere (oF)
Debug.Print oF 'Solo per debug, cancellare in seguito
Next Of
Set OggShell = Nothing 'Libera l’oggetto Shell
End Sub
La procedura estrattiva base è ripresa nel Capitolo 5 con due aggiunte, relative allo svuotamento preliminare della cartella di destinazione e a una pausa di circa 5 millisecondi che evita certi pur rari problemi nella copia di file.
Sub ZippaFileOOXLMEstraiInCart(Target As Strig, CartDestin As String)
Dim OggShell As Object, Estens As String, ZipTarget As String
'Controllo sul formato file
Estens = Right(Target, 4)
If Not (Estens = "xlsx" Or Estens = "xlsm" Or Estens = _
"docx" Or Estens = "docm") Then
MsgBox "Formato non valido!", vbCritical, "OK solo file Excel o Word 2007"
Exit Sub
End If
'Cancella tutti i file e folder della cartella destinataria
SvuotaCartella CartDestin
'Cambia l'estensione del target in zip
ZipTarget = Replace(Target, Estens, "zip")
'Metti a tacere le proteste sul cambio estensione
Application.DisplayAlerts = False
'Rinomina il target come file zip
Name Target As ZipTarget
'Controllo sul numero di elementi di ZipTarget (per debug)
Set OggShell = CreateObject("Shell.Application")
'Incredibile a dirsi: senza "" & nell'argomento 'di Namespace si ha ERRORE!!!
MsgBox "Numero item: " & OggShell.Namespace("" & ZipTarget).Items.Count
For Each oF In OggShell.Namespace("" & ZipTarget).Items
OggShell.Namespace("" & CartDestin).Copyhere (oF)
Debug.Print oF
Pausa 0.5 '500 millisec
Next oF
Set OggShell = Nothing
'Rinomina il file zip come l'originario Target
Name ZipTarget As Target
End Sub
Ecco le due routine SvuotaCartella e Pausa:
Sub SvuotaCartella(Cart As String)
'Elimina tutti i subfolder e archivi, lasciando in vita la cartella
Dim Fso As Object, specFile As String
specFile = IIf(Right(Cart, 1) <> "\", Cart & "\", "") & "*.*"
Set Fso = CreateObject("Scripting.FileSystemObject")
'Elimina subfolder eventuali a tutti i livelli
'Lasciando solo gli eventuali archivi nella radice
Fso.DeleteFolder (specFile)
'Elimina gli eventuali file residui alla radice della cartella
Fso.DeleteFile (specFile)
Set Fso = Nothing
End Sub
Sub Pausa(t As Single)
Dim TempoIniz As Single
TempoIniz = Timer
While Timer < TempoIniz + t
Wend
End Sub
Ecco infine la procedura che esegue il mestiere contrario, con la sua brava Sub di prova.
Sub CartellaOOXMLInNuovoFileOOXML(CartTarget As String, ZipDestin As String, Estens As String)
Dim OggShell As Object
If Not (Estens = "xlsx" Or Estens = "xlsm" _
Or Estens = "docx" Or Estens = "docm") Then
MsgBox "Formato non valido!", vbCritical, "OK solo file Excel o Word 2007"
Exit Sub
End If
'Creazione di un nuovo ZipDestin vuoto
Open ZipDestin For Output As #1
Print #1, Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
Close #1
Set OggShell = CreateObject("Shell.Application")
'Incredibile a dirsi: senza "" & nell'argomento di Namespace si aveva ERRORE!!!
For Each oF In OggShell.Namespace("" & CarTarget).Items
OggShell.Namespace("" & ZipDestin).Copyhere (oF)
Debug.Print oF
Pausa 0.5 '500 millisec.
Next oF
Set OggShell = Nothing
'Rinomina il file ZipDestin come file Excel o Word 2007
Application.DisplayAlerts = False 'Tacita proteste sul cambio estens.
Name DestinZip As Replace(DestinZip, "zip", Estens)
Set OggShell = Nothing
End Sub
Sub ProvaCartXMLInNuovoFIleXML()
CartellaOOXMLInNuovoFileXML "C:\TuaCart", "C:\NuovoFileXML.zip", "xlsx"
End Sub
La Sub è data quasi solo come ricetta. Anche perché l’istruzione Print #1 con quel che segue richiede il richiamo di nozioni per le quali lo spazio difetta, idem per l’utile oggetto Shell.Application già usato nella Sub di estrazione e che qui si constata applicabile pure a file zippati (buono a sapersi anche per altre circostanze!).
ALTRI SNIPPET?
Pensa e ripensa, ho infine ritenuto di inserire solo una parte delle funzioni del CAPITOLO 6, quello finale. Eccole qui sotto senza commenti (il libro va letto, signori miei...)
CAPITOLO 6
Funzione SommaValoriSuDisco
Function SommaValoriSuDisco(CartXML As String, _
Foglio As String, Zona As Range) As Double
Dim DocXml As New DOMDocument
Dim NodoXml As IXMLDOMNode
Dim Cella As Range, Rif As String, strQuery As string
Dim MaxAttr As Integer, Tot As Double
DocXml.Load (CartXML & "\xl\worksheets\" & Foglio)
For Each Cella In Zona
Rif = Cella.Address(False, False)
strQuery = "//c[@r=" & "'" & Rif & "'" & "]"
Set NodoXml = DocXml.SelectSingleNode(strQuery)
If Not NodoXml Is Nothing Then 'Escludi celle vuote
MaxAttr = NodoXml.Attributes.Length
'Escludi celle contenenti stringhe
If NodoXml.Attributes(MaxAttr - 1).Text <> "s" Then
'N.B. Il nodo v è secondo, dopo il nodo f
Tot = Tot + Val(NodoXml.LastChild.Text)
End If
End If
Next
SommaValoriSuDisco = Tot
Set DocXML = Nothing : Set NodoXml = Nothing
End Function
Possibile routine di prova:
Sub ProvaSommaValoriSuDisco()
MsgBox SommaValoriSuDisco("C:\MiaCart", "sheet1.xml", Range("B1:D4"))
End Sub
Funzione CercaParola
Function CercaParola(Parola As String, FileXML As String) As Boolean
Dim DocXml As DOMDocument
Dim NodiXml As IXMLDOMNodeList, NodoXml As IXMLDOMNode
ChDir ThisDocument.Path
'Crea una Cartella comune, se non esiste già
If Dir("CartellaComune”, VbDirectory) <> ""
MkDir "CartellaComune"
End If
SvuotaCartella "CartellaComune"
Dim Percorso As String, Targ As String, CartDest As String
Percorso = ThisDocument.Path & "\"
Targ = Percorso & FileXML
CartDest = Percorso & "CartellaComune"
ZippaFileOOXLMEstraiInCart Targ, CartDest
Set DocXml = New DOMDocument
DocXml.Load CartDest & "\word\document.xml"
Set NodiXml = DocXml.SelectNodes("//w:p")
For Each NodoXml In NodiXml
'MsgBox NodoXml.Text 'Usata per debug
If InStr(1, LCase(NodoXml.Text), LCase(Parola)) > 0 Then
CercaParola = True
Exit For
End If
Next
End Function
Routine di prova:
Sub ProvaCercaParola()
Dim ParolaMia As String, Doc As String
ParolaMia = "ambaraba": Doc = "Documento1.docx"
If CercaParola(ParolaMia, Doc) Then
MsgBox ParolaMia & " trovata!"
Else
MsgBox ParolaMia & " non trovata..."
End If
End Sub
Ricerca di una parola in più documenti Word
Sub CercaParolaInTuttiDocx()
Dim QuestiDoc As New Collection
Dim UnDoc As String, ind As Integer
ChDir ThisDocument.Path
Application.ScreenUpdating = False
UnDoc = Dir("*.docx")
While UnDoc <> ""
QuestiDoc.Add UnDoc
UnDoc = Dir
Wend
Dim ParolaMia As String, Doc As String
Dim ListaDocTrov As New Collection
While ParolaMia = ""
ParolaMia = InputBox("Che parola desideri?")
Wend
Dim Percorso As String
Percorso = ThisDocument.Path & "\"
For ind = 1 To QuestiDoc.Count
Doc = QuestiDoc(ind)
If CercaParola(ParolaMia, Doc) Then
MsgBox ParolaMia & " trovata!" & vbLf _
& "nel documento" & vbLf & Doc
ListaDocTrov.Add Percorso & Doc
End If
Next ind
'Cancella tutto (CercaParole.docm è
'riservato alla lista docomenti trovati)
Selection.WholeStory
Selection.Delete
'Elenca i documenti trovati
Selection.Range.Text = "ELENCO DOCUMENTI:"
Selection.EndKey Unit:=wdStory
For ind = 1 To ListaDocTrov.Count
Doc = ListaDocTrov(ind)
Selection.TypeParagraph 'Carriage Return
ActiveDocument.Hyperlinks.Add _
Anchor:=Selection.Range, _
Address:=Doc
Next
End Sub
Recupero di un grafico
Sub RecuperaGrafico()
ChDir ThisWorkbook.Path & "\CartParti"
Dim Rif As String, RifDatiGraf As String
Dim DocXml As New DOMDocument
DocXml.Load ("xl\charts\chart1.xml")
Set NodoXml = _
DocXml.SelectSingleNode("//c:cat/c:strRef/c:f")
'MsgBox Nodoxml.text 'Servita per debug
RifDatiGraf = RifCompleti(NodoXml.Text)
Set NodiXml = _
DocXml.SelectNodes("//c:numRef/c:f")
For Each Nodo In NodiXml
'MsgBox Nodo.Text 'Per debug
Rif = RifCompleti(Nodo.Text)
RifDatiGraf = RifDatiGraf & "," & Rif
Next
'MsgBox RifDatiGraf 'Per debug
Charts.Add
With ActiveChart
.SetSourceData Source:=Range(RifDatiGraf)
.ChartType = xl3DColumnClustered
End With
End Sub
SchemaFattura.xsd:
<?xml version="1.0"?>
<!-- Nome file: SchemaFattura.xsd -->
<xsd:schema xmlns:xsd="http://www.w3.org/2001/XMLSchema">
<xsd:element name="FATTURA">
<xsd:complexType>
<xsd:sequence>
<xsd:element name="NOME" type="xsd:string"/>
<xsd:element name="COGNOME" type="xsd:string"/>
<xsd:element name="INDIRIZZO" type="xsd:string"/>
<xsd:element name="CITTA" type="xsd:string"/>
<xsd:element name="DESCRIZIONE" type="xsd:string"/>
<xsd:element name="QUANT" type="xsd:positiveInteger"/>
<xsd:element name="PREZZO" type="xsd:decimal"/>
<xsd:element name="IMPONIBILE" type="xsd:decimal"/>
<xsd:element name="IVA" type="xsd:positiveInteger"/>
<xsd:element name="IMPORTO" type="xsd:decimal"/>
</xsd:sequence>
</xsd:complexType>
</xsd:element>
</xsd:schema>
Macro ElencaNodiDocumConSchema
Sub ElencaNodiDocumConSchema()
ChDir ThisWorkbook.Path & "\CartParti"
Dim DocXml As New DOMDocument
DocXml.Load ("word\document.xml")
'Filtra i nodi relativi allo schema XML Fattura
Dim strQyery As String
strQuery = "//w:customXml//w:customXml"
Set NodiXml = DocXml.SelectNodes(strQuery)
MsgBox "Numero nodi-testo: " _
& NodiXml.Length 'Per debug
Dim TuttoIlTesto As String
Dim NomeCampo As string, DatoCampo As String
For Each NodoXml In NodiXml
i = i + 1
NomeCampo = NodoXml.Attributes(0).Text
DatoCampo = NodoXml.Text
MsgBox "Nodo N. " & i & ":" & vbLf & _
NomeCampo & " = " & DatoCampo
TuttoIlTesto = TuttoIlTesto & " " & DatoCampo
Next
MsgBox TuttoIlTesto, vbInformation, _
"Numero nodi-testo: " & NodiXml.Length
End Sub
Have fun! (buon divertimento)
Gianni Giaccaglini
?>
?>