Macro VBA pour ecrire et lire un fichier xml

Out of category
1

Bonjour,

Je souhaite pouvoir créer un fichier xml depuis depuis solidworks et également le lire et récupérer des valeurs depuis ce fichier.

Le but est de pouvoir sauvegarder des options de CheckBox différentes suivant le poste d'ou est lancé la macro, et les récupérer au prochain lancement avec modification possible.

J'ai trouvé une méthode fonctionnel pur écrire ce fichier xml mais impossible de récupérer des valeurs (il m'insère comme un espace entre chaque lettre dans la fenêtre d'affichage de la macro et pourtant le xml est sans espace entre les lettres.

Voici le fichier xml:

<OPTIONS>
    <CheckBoxCacherPièce="Vrai">
    <CheckBoxCacherPlan="Vrai">
    <CheckBoxDesignation="Vrai">
    <CheckBoxCouleur="Vrai">
    <CheckBoxRevision="Vrai">
</OPTIONS>

La macro pour écrire:

'   Add a reference to Microsoft Scripting Runtime (click Tools > References > Browse > C:\windows\system32\scrrun.dll.

Sub ecrire()
    'Exemple XML attribute:   <Counter name="Incrementing0" Version="1" id="Incrementing0" Auto="0" AutoName="" type="1" RangeCounter="False" RangeDate="23/12/2019">

    Dim swApp As SldWorks.SldWorks
    Dim sPath As String
    Dim sPathName As String
    Dim fso As Scripting.FileSystemObject
    Dim XMLfile As Scripting.TextStream

    Set swApp = Application.SldWorks
    sPath = Environ("USERPROFILE") & "\.SaveMacroSldworks\"
    sPathName = sPath & "SaveMacroIndice.xml"
    Debug.Print sPathName
    
    'On vérifie si le dossier existe sinon on le créé
    'If Dir(sPath) = "" Then
    If Dir(sPath, vbDirectory + vbHidden) = "" Then
    Debug.Print "Création du dossier: " & sPath
    MkDir sPath
    End If


    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set XMLfile = fso.CreateTextFile(sPathName, True, True)

    XMLfile.WriteLine "<OPTIONS>"
            'On vérifie tout les objets commençant par CheckBox et on sauvegarde la valeur de l'option dans le fichier xml
            Dim ole1 As Control
            For Each ole1 In UserformOptionsMacro.Controls
            If Left$(ole1.Name, 8) = "CheckBox" Then XMLfile.WriteLine "    <" & ole1.Name & "=" & Chr(34) & ole1.Value & Chr(34) & ">"
            Next
            'XMLfile.WriteLine "    <Option 1=" & Chr(34) & True & Chr(34) & ">"

    XMLfile.WriteLine "</OPTIONS>"
    
    XMLfile.Close
    


End Sub

La macro pour lire:

Sub lire()

    Dim swApp As SldWorks.SldWorks
    Dim sPath As String
    Dim sPathName As String
    Dim fso As Scripting.FileSystemObject
    Dim XMLfile As Scripting.TextStream
    Dim stChaine As String

    Set swApp = Application.SldWorks

    sPath = Environ("USERPROFILE") & "\.SaveMacroSldworks\"
    sPathName = sPath & "SaveMacroIndice.xml"
    Debug.Print sPathName

    
    Set fso = CreateObject("Scripting.FileSystemObject")
    'Ajouter la gestion d'erreur si fichier introuvable
    Set XMLfile = fso.OpenTextFile(sPathName, ForReading, True, TristateFalse)
    
    'Read till the end
    Do Until XMLfile.AtEndOfStream
     'Debug.Print "Printing line " & XMLfile.Line
     'Debug.Print XMLfile.ReadLine 'Print a line from the file
     stChaine = XMLfile.ReadLine
     stChaine = Replace(stChaine, " ", vbNullString)
     Debug.Print stChaine
     If stChaine Like "*Checkbox*" Then MsgBox "CheckBox ok"

Loop
XMLfile.Close


End Sub

Si quelqu'un a une autre méthode plus fonctionel, un exemple ou tout simplement une piste à me communiqué, cela me permettra de faire avencé mon projet.

 

Merci d'avance.

2

Salut,

Regarde ici : https://arkham46.developpez.com/articles/office/officeweb/?page=page_4

Bonne journée et bon code.

1 « J'aime »
3

Merci remrem  pour la piste, j'avais déjà un équivalent, le soucis c'est que les exemple données provienne de macro Excel, que je n'arrive pas à transposé dans une macro SW.

Idéalement il me faudrait un exemple simple sous SW.

Je vais approfondir tout ça, et avec un peu de chance j'aurai plus d'inspiration que la semaine dernière!

4

Salut,
Quel est ton problème ?

1 « J'aime »
5

remrem  , mon soucis venait des déclaration pour excel dans solidworks.

Il semblerait que je soit sur la bonne piste j'ai réussi à créer un fichier xml grâce à ce code adapté de ton exemple:

    Option Explicit

     
' Add MS excel as reference (Outil\Référence)
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim xlApp As Excel.Application
    Dim xlSheet As Excel.Worksheet
    Dim xlBooks As Excel.Workbooks
 
    Sub Main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlSheet = xlApp.ActiveSheet
   
    'on lance la fonction ecrire le fichier xml
    CreateXMLFileVBA

    
        'clean up
    xlApp.Visible = True
    'PostMessage xlApp.hwnd, WM_QUIT, 0, 0
    
    Set xlBooks = Nothing
    Set xlApp = Nothing
    End Sub

   
Function CreateXMLFileVBA()
Debug.Print "function createXMLFIile"
Dim fic As Integer
fic = FreeFile
Open "C:\Temp\XMLFileVBA.xml" For Output As #fic
Print #fic, "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
Print #fic, "<racine>"
Print #fic, "    <info1>test élément 1</info1>"
Print #fic, "    <info2>test élément 2</info1>"
Print #fic, "    <info>"
Print #fic, "        <subinfo1>test sous-élément 1</subinfo1>"""
Print #fic, "        <subinfo2>test sous-élément 2</subinfo2>"
Print #fic, "    </info>"
Print #fic, "</racine>"
Close #fic
End Function

Il me reste plus qu'à adapter le code pour lire et rendre ça plus propre dès que j'aurais un petit moment.

Au passage si tu as des remarques pour rendre le code réalisé plus propre n'hésite pas, je suis preneur!

6

Toujours moi, après essai impossible avec la méthode Dom d'écrire ou récupérer un fichier xml, pour écrie j'ai bien l'autre méthode parfaitement fonctionnel mai impossible de récupérer les informations.

Voici le code le soucis est sûrement dans les déclaration ou référence puis ce que cette ligne est en erreur: Dim oXML As MSXML2.DOMDocument (dans la fonction) et pourtant j'ai bien ajouter Microsoft Excel 16.0 et Microsoft XML, v6.0 dans les références

Une idée d'où peu venir mon erreur?

    Option Explicit

     
' Add MS excel as reference (Outil\Référence)
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim xlApp As Excel.Application
    Dim xlSheet As Excel.Worksheet
    Dim xlBooks As Excel.Workbooks
 
    Sub Main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    Set xlSheet = xlApp.ActiveSheet
   
    'on lance la fonction ecrire le fichier xml
    'CreateXMLFileVBA
    'on lance la fonction lire le fichier xml
    ReadXMLFileXML
    
        'clean up
    xlApp.Visible = True
    'PostMessage xlApp.hwnd, WM_QUIT, 0, 0
    
    Set xlBooks = Nothing
    Set xlApp = Nothing


    End Sub

   
Function CreateXMLFileVBA()
Debug.Print "function createXMLFIile"
Dim fic As Integer
fic = FreeFile
Open "C:\Temp\XMLFileVBA.xml" For Output As #fic
Print #fic, "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
Print #fic, "<racine>"
Print #fic, "    <info1>test élément 1</info1>"
Print #fic, "    <info2>test élément 2</info1>"
Print #fic, "    <info>"
Print #fic, "        <subinfo1>test sous-élément 1</subinfo1>"""
Print #fic, "        <subinfo2>test sous-élément 2</subinfo2>"
Print #fic, "    </info>"
Print #fic, "</racine>"
Close #fic
End Function


Function ReadXMLFileXML()
Debug.Print "ReadXMLFileXML"
Dim oXML As MSXML2.DOMDocument
Set xlApp = CreateObject("MSXML2.DOMDocument")
Dim oNode As MSXML2.IXMLDOMNode



'Set oXML = New MSXML2.DOMDocument
'oXML.async = False
'oXML.Load "C:\XMLFileVBA.xml"
'For Each oNode In oXML.documentElement.childNodes
   'Debug.Print oNode.baseName
'Next

xlApp.async = False
xlApp.Load "C:\Temp\XMLFileVBA.xml"
For Each oNode In xlApp.documentElement.childNodes
   Debug.Print oNode.baseName
Next
           

End Function

    Option Explicit

     
' Add MS excel as reference (Outil\Référence)
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim xlApp As Excel.Application
    Dim xlSheet As Excel.Worksheet
    Dim xlBooks As Excel.Workbooks
 
    Sub Main()
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    Set xlSheet = xlApp.ActiveSheet
   
    'on lance la fonction ecrire le fichier xml
    'CreateXMLFileVBA
    'on lance la fonction lire le fichier xml
    ReadXMLFileXML
    
        'clean up
    xlApp.Visible = True
    'PostMessage xlApp.hwnd, WM_QUIT, 0, 0
    
    Set xlBooks = Nothing
    Set xlApp = Nothing


    End Sub

   
Function CreateXMLFileVBA()
Debug.Print "function createXMLFIile"
Dim fic As Integer
fic = FreeFile
Open "C:\Temp\XMLFileVBA.xml" For Output As #fic
Print #fic, "<?xml version=""1.0"" encoding=""ISO-8859-1""?>"
Print #fic, "<racine>"
Print #fic, "    <info1>test élément 1</info1>"
Print #fic, "    <info2>test élément 2</info1>"
Print #fic, "    <info>"
Print #fic, "        <subinfo1>test sous-élément 1</subinfo1>"""
Print #fic, "        <subinfo2>test sous-élément 2</subinfo2>"
Print #fic, "    </info>"
Print #fic, "</racine>"
Close #fic
End Function


Function ReadXMLFileXML()
Debug.Print "ReadXMLFileXML"
Dim oXML As MSXML2.DOMDocument
Set xlApp = CreateObject("MSXML2.DOMDocument")
Dim oNode As MSXML2.IXMLDOMNode



'Set oXML = New MSXML2.DOMDocument
'oXML.async = False
'oXML.Load "C:\XMLFileVBA.xml"
'For Each oNode In oXML.documentElement.childNodes
   'Debug.Print oNode.baseName
'Next

xlApp.async = False
xlApp.Load "C:\Temp\XMLFileVBA.xml"
For Each oNode In xlApp.documentElement.childNodes
   Debug.Print oNode.baseName
Next
           

End Function
7

Bonjour,

Essaye avec la macro exemple jointe.

Cordialement,


macroxml.swp
1 « J'aime »
8

Merci d.roger je venais de réussir à faire un code fonctionnel grâce à ce site: https://analystcave.com/vba-xml-working-xml-files/

Après essaie ton code fonctionne parfaitement et va sûrement m'aider à finaliser le mien, voir le remplacer en grande partie.

Il ne me reste plus qu'à retrousser mes manches!

 

Merci aussi remrem ton lien m'a bien aidé également, c'est grâce à certaines informations de ce lien que j'ai pu aboutir sur le mien avec un code plus récent et abouti et donc plus fonctionnel.