Domdocument ile XML'den veri almak

[Erdem Akdemir]

Merhaba,

Ek'te bulunan xml datasından Domdocument yöntemi ile veri almak istiyorum ama pek beceremedim.

Fatura bilgileri altındaki tablodaki veriler arasında döngü kurarak veri alabilir miyim. (matbaNoterVkno,faturaSeriSiraNo v.b.)
5010 altındaki 169508.42 nasıl alabilirim.

Sevgiler, saygılar.

 

[Erdem Akdemir]

Konu günceldir.

 

[Haluk]

Fatura bilgileri altındaki tablodaki veriler arasında döngü kurarak veri alabilir miyim. (matbaNoterVkno,faturaSeriSiraNo v.b.)
5010 altındaki 169508.42 nasıl alabilirim.

Bahsettiğiniz bilgileri aşağıdaki gibi bir kodla alabilirsiniz...

Sub Test()
    'Haluk - 22/09/2018
    '
    Dim xDoc As Object
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.async = False
    xDoc.validateOnParse = False
  
    MyFile = Application.GetOpenFilename
    If MyFile = False Then Exit Sub
  
    xDoc.Load MyFile
  
    Set MyKey = xDoc.SelectSingleNode("//matbaNoterVkno")
    Key1 = MyKey.Text
  
    Set MyKey = xDoc.SelectSingleNode("//faturaSeriSiraNo")
    Key2 = MyKey.Text

    Set MyKey = xDoc.SelectSingleNode("//tdhpGelirTablosuSatiri[kod='5010']/cd")
    Key3 = MyKey.Text
  
    MsgBox "Özet Bilgi" & vbCrLf & vbCrLf _
         & "matbaNoterVkno" & Chr(9) & "= " & Key1 & vbCrLf _
         & "faturaSeriSiraNo" & Chr(9) & "= " & Key2 & vbCrLf _
         & "Kod(5010) icin cd" & Chr(9) & "= " & Key3
End Sub

.

 

[Erdem Akdemir]

Haluk bey merhaba,

Elinize koluna sağlık.
Sizin için küçük forum için büyük bilgiler ediniyoruz.
Merak ettiğim bir şey daha var.

Fatura seri numarasından birden fazla xml şemasında var.
Bunların tamamını nasıl alabiliriz. Yada Fatura bilgileri tagının altındaki verileri For each gibi bir döngüye sokarak tamamını alabilir miyiz.

Mesala tüm gelir tablosunu döngüye sokarak tüm kodları ve tutarları nasıl alabilirim.,

Sevgiler, saygılar.

 

[Haluk]

Merhaba sayın kuvari,

Aslında araştırınca hemen her şey internette bulunabiliyor. Hepsi istediğiniz biçimde değil tabii..... emek, sabır ve zaman ayırınca kendinize uygun çözümleri kendiniz geliştirebiliyorsunuz.

Örneğin, yukarıdaki kodda ; 5010 kodu altındaki değerini XPATH kullanarak bulduk ki, bu metodu ben de sayın @Zeki Gürsoy 'dan yeni öğrenmiştim. Kendisi bu konuyu okursa, size başka alternatifler de sunabilir.

Selamlar,

.

 

[Haluk]

Bu arada; istemiş olduğunuz fatura bilgilerini aşağıdaki gibi bir kodla sayfaya alabilirsiniz....

Sub Test2()
    'Haluk - 22/09/2018
    '
    Dim xDoc As Object, MyFile As Variant, myList As Object
    Dim i As Byte, Num As Byte
    
    Range("A1:H" & Rows.Count) = ""
    
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.async = False
    xDoc.validateOnParse = False
    
    MyFile = Application.GetOpenFilename("E-Fatura (*.xml), *.xml")
    If MyFile = False Then Exit Sub
    
    xDoc.Load MyFile
    
    Set myList = xDoc.SelectNodes("//faturaBilgileri/fatura")
    
    If myList.Length = 0 Then GoTo SafeExit:
    
    Num = myList.Length - 1
    
    Range("A1:H1") = Array("Sıra No", "Merkez Şube", "Fatura Çeşidi", "matbaNoterVkno", "Noter VK No", "Seri Sıra No", "Alıcı VK No", "Tutar")
    Range("A1:H1").Font.Bold = True
    
    For i = 0 To Num
        Cells(i + 2, 1) = i + 1
        Cells(i + 2, 2) = myList(i).SelectSingleNode("merkezSube").Text
        Cells(i + 2, 3) = myList(i).SelectSingleNode("faturaCesit").Text
        Cells(i + 2, 4) = myList(i).SelectSingleNode("matbaNoterVkno").Text
        Cells(i + 2, 5) = myList(i).SelectSingleNode("faturaTarihi").Text
        Cells(i + 2, 6) = myList(i).SelectSingleNode("faturaSeriSiraNo").Text
        Cells(i + 2, 7) = myList(i).SelectSingleNode("aliciVkno").Text
        Cells(i + 2, 8) = myList(i).SelectSingleNode("tutar").Text
    Next
    
    Range("H2:H" & i + 1).NumberFormat = "#,##0.00 $"
    Range("A:H").Columns.AutoFit
SafeExit:
    Set myList = Nothing
    Set xDoc = Nothing
End Sub

.

 

[Haluk]

En son 6 No'lu mesajımdaki kodda ufak bir eksiklik vardı, revize ettim...

.

 

[Erdem Akdemir]

Haluk bey elinize sağlık.
Forum ve benim için güzel bir örnek çalışma daha oldu.

 

[Haluk]

Teşekkürler sayın kuvari;

Gelir Tablosu için de aşağıdaki gibi bir kodu kullanabilirsiniz....

Sub Test3()
    'Haluk - 22/09/2018
    '
    Dim xDoc As Object, MyFile As Variant, myList As Object
    Dim i As Byte, Num As Byte
    
    Range("A1:B" & Rows.Count) = ""
    
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.async = False
    xDoc.validateOnParse = False
    
    MyFile = Application.GetOpenFilename("E-Fatura (*.xml), *.xml")
    If MyFile = False Then Exit Sub
    
    xDoc.Load MyFile
    
    Set myList = xDoc.SelectNodes("//tdhpGelirTablosu/tdhpGelirTablosuSatiri")
    
    If myList.Length = 0 Then GoTo SafeExit:
    
    Num = myList.Length - 1
    
    Range("A1:C1") = Array("Sıra No", "Kod", "CD")
    Range("A1:C1").Font.Bold = True
    
    For i = 0 To Num
        Cells(i + 2, 1) = i + 1
        Cells(i + 2, 2) = myList(i).SelectSingleNode("kod").Text
        Cells(i + 2, 3) = myList(i).SelectSingleNode("cd").Text
    Next
    
    Range("C2:C" & i + 1).NumberFormat = "#,##0.00 $"
    Range("A:C").Columns.AutoFit
SafeExit:
    Set myList = Nothing
    Set xDoc = Nothing
End Sub

.

 

[Erdem Akdemir]

Haluk bey,

Xmlhttp'den sonra domdocument nesnesi içinde bana göre önemli örnekler oluşturuldu.Örnek uygulamalar kategorisinde olmayı hak ediyorlar.

 

[Haluk]

Artık onu Moderatör arkadaşlar takdir eder, benim haddime değil ....

.

 

[Zeki Gürsoy]

Başlıkta adım geçti ama telefondan okuyabiliyorum ancak. Zaten konuyu Haluk Bey her zaman ki gibi çözmüş.

 

[Haluk]

Rica ederim Zeki Bey,

Sizin bu tür konularda ne kadar geniş bakış açınız ve bilginiz olduğunu herkes biliyor.

Selamlar,

.

 

[Haluk]

Sayın kuvari;

Aşağıdaki kod ise "eğlence" amaçlı ve alternatif olarak hazırlanmıştır.

Burada; söz konusu E-Faturadaki Gelir Tablosu, DomDocument'ın XML özelliği kullanılarak RegExp ile ayrıştırılmakta ve sonuçlar sayfaya yazılmaktadır.

Sub Test4()
    'Haluk - 22/09/2018
    '
    Dim xDoc As Object
    Dim MyFile As Variant
    Dim arrPattern(1 To 2)
    Dim strResponseText As String
    Dim regExp As Object
    Dim r As Byte, arrIndex As Byte
    
    Range("A1:C" & Rows.Count) = ""
    Range("A1:C1") = Array("Sıra No", "Kod", "CD")
    Range("A1:C1").Font.Bold = True

    MyFile = Application.GetOpenFilename("E-Fatura (*.xml), *.xml")
    If MyFile = False Then Exit Sub
    
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.async = False
    xDoc.validateOnParse = False
    
    xDoc.Load MyFile
    
    strResponseText = xDoc.XML
    
'    arrPattern(1) = "<tdhpGelirTablosuSatiri>" & vbCrLf & String(5, vbTab) & "<kod>(.+)</kod>"
    arrPattern(1) = "<tdhpGelirTablosuSatiri>\r\n\t{5}<kod>(.+)</kod>"
    arrPattern(2) = "<cd>(.+)</cd>"
    
    Set regExp = CreateObject("VBScript.RegExp")
    
    regExp.IgnoreCase = True
    regExp.Global = True

    For Each RetVal In arrPattern
        regExp.Pattern = RetVal
        r = 1
        arrIndex = arrIndex + 1
        If regExp.Test(strResponseText) Then
            For Each myData In regExp.Execute(strResponseText)
                r = r + 1
                Cells(r, 1) = r - 1
                Cells(r, arrIndex + 1) = myData.Submatches(0)
            Next
        End If
    Next
    
    Range("C2:C" & r).NumberFormat = "#,##0.00 $"
    Range("A:C").Columns.AutoFit
    
    Set regExp = Nothing
    Set xDoc = Nothing
End Sub

Not: Kodda "arrPattern(1)" için alternatif de verilmiştir...

.

 

[Erdem Akdemir]

Haluk bey,

Verdiğiniz kodları şimdi inceleme fırsatım oldu. Tam nokta atışı olmuşlar.
İncelediğimde fark ettiğim noktalar oldu ama koda dökmedim.Mylist'in içindeki itemler ve onlarında altındaki itemlar ve üyelerin içinde istediğim herşey var.Elinize sağlık tekrardan.

 

[Haluk]

Kolay gelsin ....

.

 

[Haluk]

Tekrar merhaba sayın kuvari;

Konu hakkındaki son kod ise aşağıdadır....

Burada, daha önce yukarıda 14 No'lu mesajımda belirttiğim yöntem uygulanarak fatura bilgileri sayfaya yazılmaktadır. Yani; DomDocument'ın XML özelliği kullanılarak RegExp ile ayrıştırılmaktadır.

Sub Test5()
    'Haluk - 22/09/2018
    '
    Dim xDoc As Object
    Dim MyFile As Variant
    Dim arrPattern(1 To 7)
    Dim strResponseText As String
    Dim regExp As Object
    Dim r As Byte, arrIndex As Byte
   
    Range("A1:H" & Rows.Count) = ""
    Range("A1:H1") = Array("Sıra No", "Merkez Şube", "Fatura Çeşidi", "matbaNoterVkno", "Noter VK No", "Seri Sıra No", "Alıcı VK No", "Tutar")
    Range("A1:H1").Font.Bold = True

    MyFile = Application.GetOpenFilename("E-Fatura (*.xml), *.xml")
    If MyFile = False Then Exit Sub
   
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.async = False
    xDoc.validateOnParse = False
   
    xDoc.Load MyFile
   
    strResponseText = xDoc.XML
   
    arrPattern(1) = "<merkezSube>(.+)</merkezSube>"
    arrPattern(2) = "<faturaCesit>(.+)</faturaCesit>"
    arrPattern(3) = "<matbaNoterVkno>(.+)</matbaNoterVkno>"
    arrPattern(4) = "<faturaTarihi>(.+)</faturaTarihi>"
    arrPattern(5) = "<faturaSeriSiraNo>(.+)</faturaSeriSiraNo>"
    arrPattern(6) = "<aliciVkno>(.+)</aliciVkno>"
'    arrPattern(7) = "<tutar>(.+)</tutar>" & vbCrLf & String(4, vbTab) & "</fatura>"
    arrPattern(7) = "<tutar>(.+)</tutar>\r\n\t{4}</fatura>"
   
    Set regExp = CreateObject("VBScript.RegExp")
   
    regExp.IgnoreCase = True
    regExp.Global = True

    For Each RetVal In arrPattern
        regExp.Pattern = RetVal
        r = 1
        arrIndex = arrIndex + 1
        If regExp.Test(strResponseText) Then
            For Each myData In regExp.Execute(strResponseText)
                r = r + 1
                Cells(r, 1) = r - 1
                Cells(r, arrIndex + 1) = myData.Submatches(0)
            Next
        End If
    Next
   
    Range("H2:H" & r).NumberFormat = "#,##0.00 $"
    Range("A:H").Columns.AutoFit
   
    Set regExp = Nothing
    Set xDoc = Nothing
End Sub

Not: Kodda "arrPattern(7)" için alternatif de verilmiştir.

Ayrıca, konuya ilişkin olarak yukarıda verilen kodlar, ekli dosyada yer almaktadır.

.