Makro VBA do zapisu i odczytu pliku xml

Out of category
1

Witam

Chcę mieć możliwość utworzenia pliku xml z solidworks, a także odczytania go i pobrania wartości z tego pliku.

Celem jest możliwość zapisania różnych opcji CheckBox w zależności od komputera, z którego uruchamiane jest makro, i pobrania ich przy następnym uruchomieniu z ewentualną modyfikacją.

Znalazłem funkcjonalną metodę zapisu tego pliku xml, ale niemożliwe do pobrania wartości (wstawia mnie jako spację między każdą literą w rzutni makra, a mimo to xml jest bez spacji między literami.

Oto plik xml:

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

Makro do napisania:

'   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

Makro do odczytania:

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

Jeśli ktoś ma inną, bardziej funkcjonalną metodę, przykład lub po prostu lead, który chce mi przekazać, pozwoli mi to ruszyć do przodu z moim projektem.

 

Z góry dziękuję.

2

Witam

Zajrzyj tutaj: https://arkham46.developpez.com/articles/office/officeweb/?page=page_4

Miłego dnia i dobrego kodu.

1 polubienie
3

Dziękuję remrem  za utwór, miałem już odpowiednik, problem polega na tym, że przykładowe dane pochodzą z makra Excela, którego nie mogę przetransponować do makra SW.

Idealnie potrzebowałbym prostego przykładu pod SW.

Zamierzam zagłębić się w to głębiej i mam nadzieję, że będę miał więcej inspiracji niż w zeszłym tygodniu!

4

Witam
Na czym polega Twój problem?

1 polubienie
5

Remrem , mój problem wziął się z deklaracji dla Excela w solidworks.

Wygląda na to, że jestem na dobrej drodze, udało mi się stworzyć plik xml dzięki temu kodowi zaadaptowanemu z Twojego przykładu:

    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

Wszystko, co muszę zrobić, to dostosować kod do odczytu i uczynić go czystszym, gdy tylko będę miał trochę czasu.

Przy okazji, jeśli masz jakieś uwagi, aby kod był czystszy, nie wahaj się, jestem zainteresowany!

6

Nadal ja, po próbie niemożliwej za pomocą metody Dom zapisania lub pobrania pliku xml, do napisania mam drugą metodę doskonale działającą, ale niemożliwą do odzyskania informacji.

Oto kod, w którym problem z pewnością tkwi w deklaracji lub odwołaniu, a następnie w błędzie w tym wierszu: Dim oXML As MSXML2. DOMDocument (w funkcji), a jednak dodałem Microsoft Excel 16.0 i Microsoft XML, v6.0 w odwołaniach

Masz jakiś pomysł, skąd może wziąć się mój błąd?

    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

Witam

Spróbuj użyć załączonego przykładowego makra.

Pozdrowienia


makroxml.swp
1 polubienie
8

Dziękuję d.roger Właśnie udało mi się stworzyć funkcjonalny kod dzięki tej stronie: https://analystcave.com/vba-xml-working-xml-files/

Po wypróbowaniu Twój kod działa idealnie i na pewno pomoże mi sfinalizować mój, a nawet w większości go zastąpić.

Jedyne, co muszę zrobić, to zakasać rękawy!

 

Dziękuję również remrem twój link bardzo mi pomógł, to dzięki niektórym informacjom z tego linku udało mi się trafić na mój z nowszym i udanym kodem, a zatem bardziej funkcjonalnym.