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 Const CP_UTF8 As Long = 65001
Public Sub UTF8_Main()
Dim strText As String
Dim objRange As Range
Dim strMappenpfad As String
Dim strDateiname As String
strMappenpfad = ActiveWorkbook.Path + "\" + Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) + ".csv"
strDateiname = InputBox("Bitte den Namen der CSV-Datei angeben.", "CSV-Export", strMappenpfad)
If Get_Range(objRange) Then
If Build_Output_String(objRange, strText) Then
If Create_UTF8_File(strDateiname, strText) Then
MsgBox "Erstellen der Datei erfolgreich beendet.", _
vbInformation, "Information"
End If
End If
End If
End Sub
Private Function Get_Range(objRange As Range) As Boolean
Dim lngRow As Long, lngColumn As Long
Dim lngFirstRow As Long, lngFirstColumn As Long
Dim lngLastRow As Long, lngLastColumn As Long
Dim objLastUsedCell As Range
On Error GoTo error_handler
Set objLastUsedCell = Cells.SpecialCells(xlCellTypeLastCell)
For lngRow = objLastUsedCell.Row To 1 Step -1
If WorksheetFunction.CountBlank(Rows(lngRow)) < Columns.Count Then Exit For
Next
lngLastRow = lngRow
For lngRow = 1 To objLastUsedCell.Row
If WorksheetFunction.CountBlank(Rows(lngRow)) < Columns.Count Then Exit For
Next
lngFirstRow = lngRow
For lngColumn = objLastUsedCell.Column To 1 Step -1
If WorksheetFunction.CountBlank(Columns(lngColumn)) < Rows.Count Then Exit For
Next
lngLastColumn = lngColumn
For lngColumn = 1 To objLastUsedCell.Column
If WorksheetFunction.CountBlank(Columns(lngColumn)) < Rows.Count Then Exit For
Next
lngFirstColumn = lngColumn
Set objRange = Range(Cells(lngFirstRow, lngFirstColumn), _
Cells(lngLastRow, lngLastColumn))
Get_Range = True
Exit Function
error_handler:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler in Prozedur ''Get_Range''"
End Function
Private Function Build_Output_String(objRange As Range, strText As String) As Boolean
Dim lngRow As Long
Dim vntTempArray As Variant
On Error GoTo error_handler
With objRange
For lngRow = 1 To .Rows.Count
vntTempArray = .Rows(lngRow).Value
vntTempArray = WorksheetFunction.Transpose( _
WorksheetFunction.Transpose(vntTempArray))
strText = strText & Join(vntTempArray, ",") & vbCrLf
Next
End With
strText = Left$(strText, Len(strText) - 2)
Build_Output_String = True
Exit Function
error_handler:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler in Prozedur ''Build_Output_String''"
End Function
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, lngPointer As Long, lngSize As Long
On Error GoTo error_handler
lngLength = Len(strText)
lngPointer = StrPtr(strText)
lngSize = WideCharToMultiByte(CP_UTF8, 0&, _
lngPointer, lngLength, 0&, 0&, 0&, 0&)
ReDim bytBuffer(0 To lngSize - 1)
Call WideCharToMultiByte(CP_UTF8, 0&, lngPointer, _
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 in Prozedur ''Create_UTF8_File''"
End Function