AW: UTF-8
20.10.2006 11:08:18
bst
Auch Hallo,
mit der UTF-Routine von hier: http://www.vovisoft.com/unicode/UniFunctions.htm
cu, Bernd
--
Option Explicit
Sub SaveUTF8File()
Dim fname As Variant
fname = Application.GetSaveAsFilename("UTF8.csv", "CSV-Dateien,*.csv,Alle Dateien,*.*")
If fname <> False Then 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 = 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
'
' frei nach http://www.vovisoft.com/unicode/UniFunctions.htm#ToUTF8
'
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