VBA-macro om een xml-bestand te schrijven en te lezen

Out of category
1

Hallo

Ik wil in staat zijn om een xml-bestand te maken van solidworks en het ook te lezen en waarden op te halen uit dit bestand.

Het doel is om verschillende CheckBox-opties op te slaan, afhankelijk van de computer van waaruit de macro wordt gestart, en deze bij de volgende lancering op te halen met mogelijke aanpassingen.

Ik heb een functionele methode gevonden om dit xml-bestand te schrijven, maar het is onmogelijk om waarden op te halen (het voegt me in als een spatie tussen elke letter in de macro-viewport en toch is de xml zonder ruimte tussen de letters.

Hier is het xml-bestand:

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

De macro om te schrijven:

'   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

De macro om te lezen:

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

Als iemand een andere, meer functionele methode, een voorbeeld of gewoon een aanwijzing heeft om met mij te communiceren, kan ik verder gaan met mijn project.

 

Bij voorbaat dank.

2

Hallo

Kijk hier: https://arkham46.developpez.com/articles/office/officeweb/?page=page_4

Fijne dag en goede code.

1 like
3

Bedankt herinnering  voor de track, ik had al een equivalent, het probleem is dat de voorbeeldgegevens afkomstig zijn van een Excel-macro, die ik niet kan omzetten in een SW-macro.

Idealiter zou ik een eenvoudig voorbeeld onder SW nodig hebben.

Ik ga er dieper op in, en hopelijk heb ik dan meer inspiratie dan vorige week!

4

Hallo
Wat is je probleem?

1 like
5

 Remrem , mijn probleem kwam voort uit de declaratie voor Excel in solidworks.

Het lijkt erop dat ik op de goede weg ben, ik ben erin geslaagd om een xml-bestand te maken dankzij deze code die is aangepast aan uw voorbeeld:

    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

Het enige wat ik hoef te doen is de code aan te passen om te lezen en schoner te maken zodra ik even tijd heb.

Trouwens, als je opmerkingen hebt om de code schoner te maken, aarzel dan niet, ik ben geïnteresseerd!

6

Toch mij, na het proberen onmogelijk met de Dom-methode om een xml-bestand te schrijven of op te halen, om te schrijven heb ik de andere methode perfect functioneel, maar onmogelijk om de informatie te herstellen.

Hier is de code het probleem is zeker in de verklaring of referentie dan wat deze regel is in fout: Dim oXML As MSXML2. DOMDocument (in de functie) en toch heb ik Microsoft Excel 16.0 en Microsoft XML, v6.0 in de referenties toegevoegd

Enig idee waar mijn fout vandaan zou kunnen komen?

    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

Hallo

Probeer het met de bijgevoegde voorbeeldmacro.

Vriendelijke groeten


macroxml.swp
1 like
8

Bedankt d.roger Ik was er net in geslaagd om een functionele code te maken dankzij deze site: https://analystcave.com/vba-xml-working-xml-files/

Na het proberen werkt je code perfect en zal me zeker helpen de mijne af te ronden, of zelfs voor het grootste deel te vervangen.

Ik hoef alleen maar de handen uit de mouwen te steken!

 

Bedankt ook dat je link me ook veel heeft geholpen, het is dankzij wat informatie van deze link dat ik op de mijne kon belanden met een recentere en succesvollere code en daarom functioneler.