efa Support Forum

Code: Alles auswählen

' Funktion für Zeilumbrüche in Textaugaben
Function CrLf(Anzahl As Integer) As String
  s = ""
  n = 1
  While (n <= Anzahl)
    s = s + Chr(13) + Chr(10)
    n = n + 1
  Wend
  CrLf = s
  Exit Function
End Function

Sub crews_xml()

  Dim Param(200)
  
  ' Arrays zur Maskierung von Sonderzeichen in der xml-Importdatei
  SearchFor = Array("&", "<", ">", Chr(34))
  ReplaceWith = Array("&", "<", ">", """)
  
  ' Bildschirmausgabe unterdrücken
  Application.ScreenUpdating = False

  i = 1
  
  ' Einlesen der xml-Elemente 
  Range("A6").Activate
  
  While (ActiveCell.Value <> "")
    Param(i) = ActiveCell.Value
    ActiveCell.Offset(0, 1).Activate
    i = i + 1
  Wend
  
  ' Anzahl der xml-Elemente...
  nMaxElements = i - 1
   
  ' Ausgabedatei
  sFilename = ActiveWorkbook.Path + "\crews.xml"
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set f = fs.CreateTextFile(sFilename, True, False)

  ' xml-Header in Ausgabedate schreiben...
  f.WriteLine "<?xml version=" + Chr(34) + "1.0" + Chr(34) + " encoding=" + Chr(34) + "ISO-8859-1" + Chr(34) + "?>"
  f.WriteLine "<export type=" + Chr(34) + "text" + Chr(34) + ">"
  
  ' Verarbeitung der Datenzeilen
  Range("A9").Activate
  
  nAnzahl = 0
  bFilteredRows = False
  
  While (ActiveCell.Offset(0, 1).Value <> "")
    ' Durch einen Autofilter ausgeblendete Zeilen haben eine Zeilenhöhe von 0
    ' Die folgende if-Anweisung berücksichtigt nur Zeilen aus der Ergebnismenge eines Autofilters!
    If ActiveCell.Rows.Height > 0 Then
      i = 1
      f.Write "<Record>"
      While (i <= nMaxElements)
        
        xmlTag = "<" + Param(i) + ">"
        xmlEndTag = "</" + Param(i) + ">"
        
        Select Case Param(i)
          '  Hier werden ggf. Sonderfälle korrekt formatiert oder leere Elemente unterdrückt. Hier gezeigt am Beispiel eines Elements Birthday (z.B. in Personendaten) , dass als Datum formatiert wird...
          ' Case "Birthday"
          '  f.Write xmlTag + Format(ActiveCell.Value, "dd.mm.yyyy") + xmlEndTag
          ' Case "xxx"
          ' 
          Case Else
            If (ActiveCell.Value <> "") Then
              ' Sonderzeichen maskieren...
              sAttribut = CStr(ActiveCell.Value)
              j = LBound(SearchFor)
              While (j <= UBound(SearchFor))
                If (InStr(1, sAttribut, SearchFor(j)) > 0) Then
                  sAttribut = Replace(sAttribut, SearchFor(j), ReplaceWith(j))
                End If
                j = j + 1
              Wend 'j < UBound(SearchFor)
              f.Write xmlTag + sAttribut + xmlEndTag
            End If
        End Select
        
        ActiveCell.Offset(0, 1).Activate
        i = i + 1

      Wend
      f.WriteLine "</Record>"
      ActiveCell.Offset(1, -nMaxAttributes).Activate
      nAnzahl = nAnzahl + 1
    Else
      ' es gibt ausgefilterte Zeilen
      bFilteredRows = True
      ' nächste Datenzeile
      ActiveCell.Offset(1, 0).Activate
    End If
  Wend

  f.WriteLine "</export>"
  
  ' Ausgabedatei schließen...  
  f.Close
  
  ' Setze den Cursor wieder auf die Ausgangzelle zurück...
  Range("A6").Activate
  
  ' Bildschirmausgabe aktivieren
  Application.ScreenUpdating = True
  
  MsgText = "Parameter für " + Str(nAnzahl) + " Mannschaften wurden verarbeitet." _
        + CrLf(2) _
        + "Die Importdatei" _
        + CrLf(2) _
        + sFilename _
        + CrLf(2) _
        + "wurde erfolgreich erstellt."
        
  If bFilteredRows Then
    MsgText = MsgText + CrLf(2) _
                      + "Es wurden nur die Zeilen aus der Ergebnismenge des Autofilters berücksichtigt!"
  End If

  msg = MsgBox(MsgText, _
        vbOKOnly, _
        "Itzehoer Wasser-Wanderer e.V. - Importdatei (xml) für Mannschaften erstellen...")
   
End Sub