per Makro UTF-8 codiert speichern

Sub Test() Dim strDateiname As String, strPath As String Dim i As Long, lngZeile As Long strPath = "E:\" 'Speicherpfad eintragen strDateiname = "test.txt" 'Dateinamen mit Dateiendung eintragen lngZeile = Range("A" & Rows.Count).End(xlUp).Row Open strPath & strDateiname For Output As #1 For i = 1 To lngZeile If Range("spalte1").Cells(i) = "x" Then Print #1, Cells(i, Range("spalte-a").Column).Value & vbTab & Cells(i, Range("spalte-b").Column).Value & vbTab & Cells(i, Range("spalte-c").Column).Value Next i Close #1 End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc][+][-] Option Explicit Public Sub Test() Const DRIVE As String = "G:\" ' Speicherpfad eintragen Const FILE As String = "test.txt" ' Dateinamen mit Dateiendung eintragen Dim lngRow As Long Dim objFileSystemObject As Object, objTextStream As Object Set objFileSystemObject = CreateObject(Class:="Scripting.FileSystemObject") Set objTextStream = objFileSystemObject.CreateTextFile( _ Filename:=DRIVE & FILE, Overwrite:=True, Unicode:=True) For lngRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row If Range("spalte1").Cells(lngRow).Value = "x" Then _ Call objTextStream.WriteLine( _ Cells(lngRow, Range("spalte-a").Column).Value & vbTab & _ Cells(lngRow, Range("spalte-b").Column).Value & vbTab & _ Cells(lngRow, Range("spalte-c").Column).Value) Next lngRow Call objTextStream.Close Set objTextStream = Nothing Set objFileSystemObject = Nothing End Sub

Hallo Ingo,
teste das mal:

Code:


[Cc][+][-]

Option Explicit

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

Private Const CP_UTF8 As Long = 65001

Public Sub Test()

  Const DRIVE As String = "G:&bsol;"    ' Speicherpfad eintragen
  Const FILE As String = "test.txt"    ' Dateinamen mit Dateiendung eintragen

  Dim lngRow As Long
  Dim strText As String

  For lngRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row

      If Range("spalte1").Cells(lngRow).Value = "x" Then strText = strText & vbCrLf & _
      Cells(lngRow, Range("spalte-a").Column).Value & vbTab & _
      Cells(lngRow, Range("spalte-b").Column).Value & vbTab & _
      Cells(lngRow, Range("spalte-c").Column).Value

  Next lngRow

  If Create_UTF8_File(DRIVE & FILE, Mid$(strText, 2)) Then MsgBox "OK"

End Sub

Private Function Create_UTF8_File(strFileName As String, strText As String) As Boolean

  Dim intFileNumber As Integer
  Dim bytBuffer() As Byte
  Dim lngLength As Long, lngptrPointer As LongPtr, lngSize As Long

  On Error GoTo error_handler

  lngLength = Len(strText)
  lngptrPointer = StrPtr(strText)

  lngSize = WideCharToMultiByte(CP_UTF8, 0&, _
  lngptrPointer, lngLength, 0&, 0&, 0&, 0&)

  ReDim bytBuffer(0 To lngSize - 1)

  Call WideCharToMultiByte(CP_UTF8, 0&, lngptrPointer, _
  lngLength, VarPtr(bytBuffer(0)), lngSize, 0&, 0&)

  If Dir$(strFileName) <> vbNullString Then Call Kill(strFileName)

  Reset
  intFileNumber = FreeFile

  Open strFileName For Binary Access Write As #intFileNumber
     Put #intFileNumber, , bytBuffer
  Close #intFileNumber

  Create_UTF8_File = True

  Exit Function

error_handler:

  MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
  Err.Description, vbCritical, "Fehler im Modul        ' 'Create_UTF8_File''"

End Function

Gruß
Nepumuk

Sub Test() Dim strDateiname As String, strPath As String Dim i As Long, lngZeile As Long Dim myTextLine As String Dim objStream As Object strPath = "E:\" 'Speicherpfad eintragen strDateiname = "test.txt" 'Dateinamen mit Dateiendung eintragen Set objStream = CreateObject("ADODB.Stream") objStream.Charset = "utf-8" objStream.LineSeparator = -1 '(CRLF) objStream.Open lngZeile = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To lngZeile If Range("spalte1").Cells(i) = "x" Then myTextLine = Cells(i, Range("spalte-a").Column).Value & vbTab & _ Cells(i, Range("spalte-b").Column).Value & vbTab & _ Cells(i, Range("spalte-c").Column).Value objStream.writetext myTextLine, 1 End If Next i objStream.SaveToFile strPath & strDateiname, 1 Set objStream = Nothing End Sub

objStream.SaveToFile strPath & strDateiname, 2 ' 1 Default. Creates a new file if the file does not already exist ' 2 Overwrites the file with the data from the currently open Stream object, if the file already exists

If NoBOM Then Set objStreamNoBOM = CreateObject("ADODB.Stream") objStreamNoBOM.Type = 1 ' adTypeBinary objStreamNoBOM.Open objStream.Position = 3 objStream.CopyTo objStreamNoBOM objStreamNoBOM.SaveToFile strPath & strDateiname, 2 Set objStreamNoBOM = Nothing Else objStream.SaveToFile strPath & strDateiname, 2 End If Set objStream = Nothing

Sub xxx() Const NoBOM = True Dim strDateiname As String, strPath As String Dim i As Long, lngZeile As Long Dim myTextLine As String Dim objStream As Object Dim objStreamNoBOM As Object strPath = "C:\xxx\" 'Speicherpfad eintragen strDateiname = "xxx.xml" 'Dateinamen mit Dateiendung eintragen Set objStream = CreateObject("ADODB.Stream") objStream.Charset = "utf-8" objStream.LineSeparator = -1 '(CRLF) objStream.Open lngZeile = Range("A" & Rows.Count).End(xlUp).Row myTextLine = myTextLine & "xxx" & vbCrLf For i = 2 To 32 myTextLine = myTextLine & "xxx" & vbCrLf Next i myTextLine = myTextLine & "xxx" & vbCrLf objStream.writetext myTextLine, 1 objStream.SaveToFile strPath & strDateiname, 2 Set objStream = Nothing If NoBOM Then Set objStreamNoBOM = CreateObject("ADODB.Stream") objStreamNoBOM.Type = 1 ' adTypeBinary objStreamNoBOM.Open objStream.Position = 3 objStream.CopyTo objStreamNoBOM objStreamNoBOM.SaveToFile strPath & strDateiname, 2 Set objStreamNoBOM = Nothing Else objStream.SaveToFile strPath & strDateiname, 2 End If Set objStream = Nothing End Sub

Sub xxx() Const NoBOM = True Dim strDateiname As String, strPath As String Dim i As Long, lngZeile As Long Dim myTextLine As String Dim objStream As Object Dim objStreamNoBOM As Object strPath = "C:\xxx\" 'Speicherpfad eintragen strDateiname = "xxx.xml" 'Dateinamen mit Dateiendung eintragen Set objStream = CreateObject("ADODB.Stream") objStream.Charset = "utf-8" objStream.LineSeparator = -1 '(CRLF) objStream.Open lngZeile = Range("A" & Rows.Count).End(xlUp).Row myTextLine = myTextLine & "xxx" & vbCrLf For i = 2 To 32 myTextLine = myTextLine & "xxx" & vbCrLf Next i myTextLine = myTextLine & "xxx" & vbCrLf objStream.writetext myTextLine, 1 If NoBOM Then Set objStreamNoBOM = CreateObject("ADODB.Stream") objStreamNoBOM.Type = 1 ' adTypeBinary objStreamNoBOM.Open objStream.Position = 3 objStream.CopyTo objStreamNoBOM objStreamNoBOM.SaveToFile strPath & strDateiname, 2 Set objStreamNoBOM = Nothing Else objStream.SaveToFile strPath & strDateiname, 2 End If Set objStream = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

per Makro UTF-8 codiert speichern

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread