Office: (Office 2013) XML Datei als UTF-8 speicher

vba neuling1 · 23. November 2014

Hi,

ich hätte ein Problem. Aus einer Exceldatei erstelle ich mit einem Makro eine XML-Datei. Dies geht super. Leider brauche ich die Datei als UTF-8.

Hoffentlich kann mir einer helfen.

Vielen, vielen Dank

Code:

Sub Landwirt_XML()

' XML-Datei erstellen

Dim Datei As String, Text As String
Dim Zeile As Long
Dim zeigen

'On Error GoTo Hell

'Zieldatei festlegen
Datei = ThisWorkbook.Path & "\xxx\xx_xx\xx_xxx.xml"

Open Datei For Output As #1 'Zieldatei öffnen

' Landwirttabelle öffnen und letzte Zeile auslesen
Workbooks.Open (ThisWorkbook.Path & "\Landwirt\Landwirt.xlsx")

' Letzte Zeile auslesen

Dim LastRow2 As Integer
LastRow2 = Range("A" & Rows.Count).End(xlUp).Row

'reinschreiben
Print #1, ""
Print #1, ""

Print #1, "

:)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Backowe · 25. November 2014

Hi,

da sich bis jetzt noch niemand gemeldet hat, schreibe ich was dazu:

1. Möglichkeit: Benutze Notepad++, öffne deine Textdatei, über Kodierung diese auf UTF-8 umstellen, speichern, fertig.

2. Möglichkeit: Suchmaschine deiner Wahl, Suchbegriff "vba utf-8 csv schreiben", dann wirst du von Beispielen erschlagen. *wink.gif*

bst · 25. November 2014

Auch Hallo,

mit ADODB.Stream: http://www.tutorials.de/forum/visual...8-charset.html

oder mit der Win-API: FAQ 0155: Wie konvertiere ich eine VB-Zeichenkette nach UTF-8 oder zurück? - ActiveVB

oder selbstgemacht: http://www.excel-center.de/foren/read.php?2,51523,52235

Alle 3 Varianten funktionieren hier.

HTH, Bernd

vba neuling1 · 26. November 2014

vielen Dank für Eure Antworten. Hatte die CSV und XML Typen nicht ganz auf dem Schrim.

Habe nun versucht, die eine Lösung anzupassen. Leider erstellt er nicht aus der gespeicherten XML Datei die UTF8 sondern aus eineren.

Vielleicht kann mir einer dabei helfen den Code anzupassen.

Ich will die XML öffnen, umschreiben und dann im gleichn Ordner speichern.

Hier schon mal mein Versuch.

Code:

Sub SaveUTF8File()
Dim fname As Variant
fname = Shell(Environ("windir") & "\notepad.exe " & ThisWorkbook.Path & "\Landwirt\Landwirt_xxx\xxxx_xxx.xml", 1)
If fname = False Then Exit Sub
SaveAsUTF8CSV (fname)
End Sub
Sub SaveAsUTF8CSV(fname As String)
Dim hfile As Integer ' Filehandle bzw. Dateinummer
Dim i As Long ' Zähler über alle Zeilen
Dim j As Integer ' Zähler über alle Spalten
Dim OneLine As String ' Eine Zeile als String
Dim maxcol As Integer ' max. Anzahl an Spalten

' hfile = Shell(Environ("windir") & "\notepad.exe " & ThisWorkbook.Path & "\Landwirt\Landwirt_xxx\xxx_xxx.xml", 1)
' Workbooks.Open (ThisWorkbook.Path & "\Landwirt\Landwirt_xxx\xxx_Landwirt.xml")
hfile = FreeFile
maxcol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column

Open fname For Output As #hfile
Print #hfile, Chr(&HEF); Chr(&HBB); Chr(&HBF);
For i = 1 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
OneLine = ""
For j = 1 To maxcol - 1
OneLine = OneLine & Cells(i, j).Text & ";"
Next j
OneLine = OneLine & Cells(i, j).Text & vbCrLf
Print #hfile, GetUTF8String(OneLine);
Next i
Close #hfile
End Sub

Private Function GetUTF8String(s As String) As String
Dim i As Integer ' Zähler über die einzelnen Zeichen des utf16-Strings
Dim utf16 As Long, uc(2) As Byte

GetUTF8String = ""
For i = 1 To Len(s)
utf16 = AscW(Mid(s, i, 1))
If utf16 < 0 Then utf16 = utf16 + 65536
If utf16 < &H80 Then ' 1 Byte
GetUTF8String = GetUTF8String & Chr(utf16)
ElseIf utf16 < &H800 Then ' 2 Byte
uc(1) = &H80 + (utf16 And &H3F) ' Least Significant 6 bits
utf16 = utf16 \ &H40 ' Shift UTF16 number right 6 bits
uc(0) = &HC0 + (utf16 And &H1F) ' Use 5 remaining bits
GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1))
Else ' 3 Byte
uc(2) = &H80 + (utf16 And &H3F) ' Least Significant 6 bits
utf16 = utf16 \ &H40 ' Shift UTF16 number right 6 bits
uc(1) = &H80 + (utf16 And &H3F) ' Use next 6 bits
utf16 = utf16 \ &H40 ' Shift UTF16 number right 6 bits again
uc(0) = &HE0 + (utf16 And &HF) ' Use 4 remaining bits
GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1)) & Chr(uc(2))
End If
Next
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Meine Kenntnisse sind da doch nicht so groß.

Vielen lieben Dank

Backowe · 26. November 2014

Hi,

ich mache dir mal einen ernst gemeinten Vorschlag, bevor du ein Posting abschickst, kontrolliere bitte den Text den du geschrieben hast, ob dieser verständlich ist. Dein letztes Posting lässt jede Menge Interpretationen zu.

Falls ich dich richtig verstanden habe, kann es so funktionieren:
Code:

Code:

Option Explicit

Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long

Private Declare Function MultiByteToWideChar Lib "kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long) As Long

Private Const CP_UTF8 As Long = 65001

Sub SpeichereAlsUTF8()
Dim strText As String

strText = txt_ReadAll("c:\users\" & Environ("UserName") & "\Desktop\test.xml")
WriteUTF8File "c:\users\" & Environ("UserName") & "\Desktop\test.xml", strText
End Sub

Private Sub WriteUTF8File(ByRef FileName As String, ByRef Contents As _
String)

Dim FileNumber As Integer
Dim Buffer() As Byte

Buffer = ConvertToUTF8(Contents)
FileNumber = FreeFile
Open FileName For Binary Access Write As #FileNumber
Put #FileNumber, , Buffer
Close #FileNumber
End Sub

Private Function ConvertToUTF8(ByRef Source As String) As Byte()
Dim Length As Long
Dim Pointer As Long
Dim Size As Long
Dim Buffer() As Byte

Length = Len(Source)
Pointer = StrPtr(Source)
Size = WideCharToMultiByte(CP_UTF8, 0, Pointer, Length, 0, 0, 0, 0)
Redim Buffer(0 To Size - 1)

WideCharToMultiByte CP_UTF8, 0, Pointer, Length, VarPtr(Buffer(0)), _
Size, 0, 0
ConvertToUTF8 = Buffer
End Function

Public Function txt_ReadAll(ByVal sFilename As String) As String
Dim F As Integer
Dim sInhalt As String
If Dir$(sFilename, vbNormal) <> "" Then
F = FreeFile
Open sFilename For Binary As #F
sInhalt = Space$(LOF(F))
Get #F, , sInhalt
Close #F
End If
txt_ReadAll = sInhalt
End Function

Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

vba neuling1 · 26. November 2014

Lieber Backowe,

vielen Dank!!

die Datei sieht zwar fast gleich aus, aber es funktioniert!!

DANKE DANKE und sorry für die Umstände!!

Office: (Office 2013) XML Datei als UTF-8 speicher

XML Datei als UTF-8 speicher

XML Datei als UTF-8 speicher

XML Datei als UTF-8 speicher

XML Datei als UTF-8 speicher - Similar Threads - XML Datei UTF

Import von XML-Dateien in Access

Was geht verloren, wenn ich die Arbeitsmappe als eine XML-Kalkulationstabelle 2003-Datei ...

XML Datei erstellen

XML Datei einlesen

VBA im aus vielen Dateien XML´s zu erstellen

xml datei importieren

Problem beim Speichern als .xml Datei