BOMsuz UTF-8 .txt kaydetme

[Kardiyak]

Selamlar. Sorunum excel dosyasındaki verileri txt dosyasına UTF-8 BOM suz yazdıramamak."sayfa 1" adında bir sheet içinde C, D sütunlarında veriler var. Bunları arasında eşittir işareti olacak şekile alt alta bir txtye yazdırmaya çalışıyorum.

öncelikle şu kodları denedim. ANSI kaydetti

Sub txtdeneme1()
son = Cells(1048576, 1).End(xlUp).Row
dosya = ThisWorkbook.Path & "\1.txt"

Open dosya For Output As #1
For x = 2 To son
    If Range("C" & x) <> "" Then
        satır = Range("C" & x) & "=" & Range("D" & x)
        Else
        satır = ""
        End If
    Print #1, satır & vbNewLine
Next x
Close
End Sub

Sub txtdeneme2() 'ansi
Dim FSO, Out As Object
son = Cells(1048576, 1).End(xlUp).Row
dosya = ThisWorkbook.Path & "\1.txt"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set Out = FSO.CreateTextFile(dosya, True, False) '2.true
For x = 2 To son
    If Range("C" & x) <> "" Then
        satır = Range("C" & x) & "=" & Range("D" & x)
        Else
        satır = ""
        End If
    Out.WriteLine (satır)
Next x
Out.Close

End Sub

bu kod ile utf-8 with bom kaydedebildim.

Sub txtdeneme3() 'utf8 +bom
Dim FSO As Object
son = Cells(1048576, 1).End(xlUp).Row
dosya = ThisWorkbook.Path & "\1.txt"

Set FSO = CreateObject("ADODB.Stream")
FSO.Charset = "utf-8"
FSO.Open
For x = 2 To son
    If Range("C" & x) <> "" Then
        satır = Range("C" & x) & "=" & Range("D" & x)
        Else
        satır = ""
        End If
    FSO.WriteText satır & vbNewLine
Next x
FSO.SaveToFile dosya, 2

End Sub

Sonra elle veriyi yeni bir sayfaya kopyalayıp bunu farklı kaydetten sekmelere ayrılmış txt olarak aktardığımda bu dosyanın utf-8 without bom olarak kaydedildiğini gördüm ve bunu kod olarak yazayım dediğim.
Ama makro ile aynı işlem yapıldığında yine ansi oldu.

Sub txtdeneme4()
son = Cells(1048576, 1).End(xlUp).Row
dosya = ThisWorkbook.Path & "\1.txt"
y = 1

Sheets.Add After:=Sheets(Sheets.Count)
For x = 2 To son
    If Sheets("sayfa 1").Range("C" & x) <> "" Then
        satır = Sheets("sayfa 1").Range("C" & x) & "=" & Sheets("sayfa 1").Range("D" & x)
        Else
        GoTo atla1
        End If
    Range("A" & y) = satır
atla1:
    y = y + 1
Next x

Sheets(Sheets.Count).Move
ActiveWorkbook.SaveAs filename:=dosya, FileFormat:=xlText
ActiveWindow.Close False

End Sub

Elle kaydederken uyumlu olmayan özelliklerin çıkarılması için bir uyarıya evet diyorum. makroda öyle bir uyarı çıkmıyor bundan dolayımıdır acaba.

Makro ile Bom içermeyen bir UTF-8 txt dosyası nasıl oluşturabilirim?

 

[veyselemre]

İnternetten bulduğum bir kodu uyarlamaya çalıştım. İnşallah çalışır.

Sub test()

    Dim objStreamUTF8: Set objStreamUTF8 = CreateObject("ADODB.Stream")
    Dim objStreamUTF8NoBOM: Set objStreamUTF8NoBOM = CreateObject("ADODB.Stream")
    
    With objStreamUTF8
        .Charset = "UTF-8"
        .Open

        For x = 2 To Cells(Rows.Count, 1).End(xlUp).Row
            If Range("C" & x) <> "" Then
                satır = Range("C" & x) & "=" & Range("D" & x)
            Else
                satır = ""
            End If
            .WriteText satır & vbNewLine
        Next x

        .Position = 0
        .SaveToFile "d:\toto.php", 2
        .Type = 1
        .Position = 3
    End With

    With objStreamUTF8NoBOM
        .Type = 1
        .Open
        objStreamUTF8.CopyTo objStreamUTF8NoBOM
        .SaveToFile "d:\toto-nobom.php", 2
    End With

    objStreamUTF8.Close
    objStreamUTF8NoBOM.Close
End Sub

 

[Kardiyak]

Teşekkürler benzer bir kod bende bulmuştum ama uyarlama için çok karışık gelmişti. Mantık olarak; bom ilk 3 byte ta bulunuyormuş ve ilk dosyayı oluşturduktan sonra bunu tekrar 3. pozisyondan itibaren yani bomdan sonraki kısımdan itibaren okuyarak yazdırıyor. fazlalıkları temizlerken ilk CreateObject("ADODB.Stream")i ikinci bunu okumadan önce kapatmışım. Sadeleştirdiğiniz kodda bunu görmüş oldum. aşağıda istediğim işi yapacak şekilde çok az düzelttiğim kodunuz. Teşekkürler.

Sub test()

Dim objStreamUTF8: Set objStreamUTF8 = CreateObject("ADODB.Stream")
Dim objStreamUTF8NoBOM: Set objStreamUTF8NoBOM = CreateObject("ADODB.Stream")
dosya = "1.txt"
With objStreamUTF8
.Charset = "UTF-8"
.Open

For x = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Range("C" & x) <> "" Then
satır = Range("C" & x) & "=" & Range("D" & x)
Else
satır = ""
End If
.WriteText satır & vbNewLine
Next x

.Position = 0
.SaveToFile ThisWorkbook.Path & "\" & "bom" & dosya, 2
.Type = 1
.Position = 3
End With

With objStreamUTF8NoBOM
.Type = 1
.Open
objStreamUTF8.CopyTo objStreamUTF8NoBOM
.SaveToFile ThisWorkbook.Path & "\" & dosya, 2
End With

objStreamUTF8.Close
objStreamUTF8NoBOM.Close
kill ThisWorkbook.Path & "\" & "bom" & dosya
End Sub