Public Sub SaveUTF8(sFile As String, TStr)
' Save given Text string in UTF-8 format
   Dim a(2) As Byte
   Dim BArray() As Byte
   Dim BArrayTemp() As Byte
   Dim FileNum
   Dim bExist As Boolean
   Dim sSourceText As String
   Dim ch As String
   Dim l As Long
 
   ' Place BOM of UTF-8 in first 3 bytes
   a(0) = &HEF
   a(1) = &HBB
   a(2) = &HBF
   ' Delete output file if it exists
   If Dir(sFile) <> "" Then
    bExist = True
   End If
 
   FileNum = FreeFile ' Obtain a File handle from the OS
   Open sFile For Binary As #FileNum
   If bExist = True Then
    'wenn datei existiert dann erstmal datei in byte array einlesen
    Do While Not EOF(FileNum)
       ReDim Preserve BArray(l)
       ch = Input(1, #FileNum)
       If ch <> "" Then
         BArray(l) = Asc(ch): l = l + 1
       End If
    Loop
   Else
    Put #FileNum, , a  ' Write BOM bytes
   End If
 
   ' Convert the Unicode string to UTF-8 byte array
   BArray = UniStrToUTF8(IIf(bExist = True, vbCrLf & TStr, TStr), l)
   Put #FileNum, , BArray ' Write byte array to file
   Close #FileNum  ' Close the file
End Sub
 
Private Function UniStrToUTF8(UniString, k As Long) As Byte()
' Convert a Unicode string to a byte stream of UTF-8
Dim BArray() As Byte
Dim TempB() As Byte
Dim i As Long
'Dim k As Long
Dim TLen As Long
Dim b1 As Byte
Dim b2 As Byte
Dim UTF16 As Long
Dim j
   TLen = Len(UniString) ' Obtain length of Unicode input string
   If TLen = 0 Then Exit Function ' get out if there's nothing to convert
   k = 0
   For i = 1 To TLen
      ' Work out the UTF16 value of the Unicode character
      CopyMemory b1, ByVal StrPtr(UniString) + ((i - 1) * 2), 1
      CopyMemory b2, ByVal StrPtr(UniString) + ((i - 1) * 2) + 1, 1
    ' Combine the 2 bytes into the Unicode UTF-16
      UTF16 = b2 ' assign b2 to UTF16 before multiplying by 256 to avoid 
      ' overflow
      UTF16 = UTF16 * 256 + b1
      ' Convert UTF-16 to 2 or 3 bytes of UTF-8
      TempB = ToUTF8(UTF16)
      ' Copy the resultant bytes to BArray
      For j = 0 To UBound(TempB)
        ReDim Preserve BArray(k)
        BArray(k) = TempB(j): k = k + 1
      Next
      ReDim TempB(0)
   Next
   UniStrToUTF8 = BArray ' Return the resultant UTF-8 byte array
 
End Function
 
Private Function ToUTF8(ByVal UTF16 As Long) As Byte()
' Convert a 16bit UTF-16BE to 2 or 3 UTF-8 bytes
Dim BArray() As Byte
  If UTF16 < &H80 Then
    ReDim BArray(0) ' one byte UTF-8
    BArray(0) = UTF16 ' Use number as is
  ElseIf UTF16 < &H800 Then
    ReDim BArray(1) ' two byte UTF-8
    BArray(1) = &H80 + (UTF16 And &H3F)  ' Least Significant 6 bits
    UTF16 = UTF16 \ &H40  ' Shift UTF16 number right 6 bits
    BArray(0) = &HC0 + (UTF16 And &H1F) ' Use 5 remaining bits
  Else
    ReDim BArray(2) ' three byte UTF-8
    BArray(2) = &H80 + (UTF16 And &H3F)  ' Least Significant 6 bits
    UTF16 = UTF16 \ &H40  ' Shift UTF16 number right 6 bits
    BArray(1) = &H80 + (UTF16 And &H3F) ' Use next 6 bits
    UTF16 = UTF16 \ &H40  ' Shift UTF16 number right 6 bits again
    BArray(0) = &HE0 + (UTF16 And &HF)  ' Use 4 remaining bits
  End If
  ToUTF8 = BArray  ' Return UTF-8 bytes in an array
End Function