vb-Zentrum
Unicode Dateihandling
http://www.vb-zentrum.de/unidateihandling.html

© 2024 vb-Zentrum

Unicode Dateihandling

Die Dateifunktionen in VBA unterstützen ausnahmslos kein Unicode. Hier finden Sie entsprechende Ersatzlösungen.

Um die Unicode Implementierung so einfach wie möglich zu gestalten haben einige Funktionen den gleichen Namen, wie das VBA Original. Diese Funktionen sind im Titel mit "(VBA-Overwrite)" gekennzeichnet! Wenn Sie also die hier beschriebenen Funktionen in Ihren Code einfügen, so werden durch diese Technik die VBA Funktionen gewissermaßen überschrieben; d.h.:

Ihr Code muss nicht verändert werden und unterstützt ab sofort Unicode!

In dieser Rubrik unterscheiden wir Funktionen die mit Unicode Dateinamen arbeiten (ab Tipp 0001)
und Funktionen die mit Unicode Dateiinhalten arbeiten (ab Tipp 1001).

Übersicht

Vorbedingungen

Viele der folgenden Beispiele benutzen die globale, boolsche Variable isUnicode, sowie die Compiler Konstante #ANSISupport.

Beide sind in den folgenden Beispielen aus Platzgründen nicht enthalten und werden deshalb hier zentral beschrieben:

  • Compiler Konstante #ANSISupport
    hiermit wird projektweit entschieden, ob Ihre Anwendung auch auf Systmen vor Windows 2000 laufen soll (#ANSISupport <> 0).
    Um die ANSI Unterstützung zu aktivieren gehen Sie folgendermaßen vor:

    rufen Sie in der IDE den Dialog der Projekteigenschaften auf (Menü: "Projekt" -> "Eigenschaften von [Projektname]...")
    Wechseln Sie auf die Registerkarte "Erstellen"
    Geben Sie in das Feld "Argumente für bedingte Kompilierung" folgenden Text ein: ANSISupport = 1
  • Globale Variable isUnicode
    Wenn die Compiler Konstate #ANSISupport <> 0 ist: dann wird die ANSI Variante auf Nicht-NT-System benutzt,
    anderenfalls die UNICODE Variante.

Deshalb muss diese Variable in einem Modul angelegt werden und über folgende Funktion vor allen weiteren Aufrufen initialisiert werden:

Option Explicit

Public isUnicode As Boolean

' Deklaration:
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Long

' Typendefinition:
Private Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
End Type

Private Const VER_PLATFORM_WIN32_NT = 2


' Funktion:
' Prüft auf NT-Betriebssysteme: True ab Windows NT/2000 und neuer, sonst False
Public Function isSystemNT() As Boolean
  Dim info As OSVERSIONINFO

  info.dwOSVersionInfoSize = Len(info)
  GetVersionExA info
  isSystemNT = (info.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function

' Initialisierungs-Aufruf:
isUnicode = isSystemNT()

Übrigens: wenn Sie die Beispiele nicht einzelnd kopieren möchten, können Sie auch das fertige Modul vbzGlobal.bas herunterladen.
Darin ist (fast) alles enthalten, was hier zu finden ist. Benutzen Sie diese Tipp-Seite dann einfach als erweiterte Dokumentation...

Nach oben

0001 file_exist - eine bestimmte Datei auf Existenz prüfen

In nahezu jedem Programm benötigt. Hier die wohl schnellste Variante, die das Vorhandensein über das Dateiattribut abfragt. Nachteil: es muß ein kompletter Dateiname übergeben werden, die Verwendung von s.g. Wildcards (? und * im Dateinamen) ist nicht zulässig:

  • Beachten Sie die Vorbedingungen
  • Diese Funktion ist Bestandteil des Moduls vbzGlobal.bas, das sie hier kostenlos herunterladen können.
Private Declare Function GetFileAttributesA Lib "kernel32" (ByVal lpFileName As String) As Long
Private Declare Function GetFileAttributesW Lib "kernel32" (ByVal lpFileName As Long) As Long
Private Const INVALID_FILE_ATTRIBUTES As Long = -1

Public Function file_exist(ByVal file As String) As Boolean
  Dim dwAttributes As Long
  
  If (file = vbNullString) Then Exit Function
  #If ANSISupport Then
    If isUnicode Then
      dwAttributes = GetFileAttributesW(StrPtr(file))
    Else
      dwAttributes = GetFileAttributesA(file)
    End If
  #Else
    dwAttributes = GetFileAttributesW(StrPtr(file))
  #End If
  If dwAttributes = INVALID_FILE_ATTRIBUTES Then
    file_exist = False
  Else
    file_exist = (dwAttributes And vbDirectory) = 0
  End If
End Function
 

Autor: Ralf Schlegel
Stand: 12/2012

Nach oben

0002 anyfile_exist - eine Datei auf Existenz prüfen

In nahezu jedem Programm benötigt. Hier die etwas aufwendigere Alternative zu Tipp 0001 mit Unterstützung
von Wildcards (? und * im Dateinamen).
Angenehm: die Struktur WIN32_FIND_DATA kann ausnahmsweise für die ANSI und Unicode Variante benutzt werden:

  • Beachten Sie die Vorbedingungen
  • Diese Funktion ist Bestandteil des Moduls vbzGlobal.bas, das sie hier kostenlos herunterladen können.
Public Const MAX_PATH As Long = 260
Public Const INVALID_HANDLE_VALUE As Long = -1

Public Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
  FileAttributes As Long
  CreationTime As FILETIME
  LastAccessTime As FILETIME
  LastWriteTime As FILETIME
  nFileSizeBig As Currency
  Reserved0 As Long
  Reserved1 As Long
  FileName As String * MAX_PATH
  AlternateFileName As String * 14
End Type

#If ANSISupport Then
  Public Declare Function FindFirstFileA Lib "kernel32" _
                 (ByVal lpFileName As String, lpFFData As WIN32_FIND_DATA) As Long
#End If
Public Declare Function FindFirstFileW Lib "kernel32" _
               (ByVal lpFileName As Long, ByVal lpFFData As Long) As Long
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Public Function anyfile_exist(ByVal file As String) As Boolean
  Dim hFile As Long
  Dim FD As WIN32_FIND_DATA
  
  #If ANSISupport Then
    If isUnicode Then
      hFile = FindFirstFileW(StrPtr(file), VarPtr(FD))
    Else
      hFile = FindFirstFileA(file, FD)
    End If
  #Else
    hFile = FindFirstFileW(StrPtr(file), VarPtr(FD))
  #End If
  If hFile <> INVALID_HANDLE_VALUE Then
    anyfile_exist = True
    FindClose hFile
  End If
End Function
 

Autor: Ralf Schlegel
Stand: 12/2012

Nach oben

0003 GetAttr und SetAttr - erweiterte Dateiattribute (VBA-Overwrite)

Die VBA Funktionen GetAttr und SetAttr sind definitiv veraltet: unterstützen kein Unicode und keine Netzwerkpfade, außerdem stehen neuere Attribute, wie z.B.: compressed, nicht direkt in der Eingabe zur Verfügung, da sie in der Enumeration des alten VBA nicht angelegt wurden.

Der folgende Codeabschnitt zeigt den besser funktionierenden API-Ersatz, der neben Unicode auch UNC-Path unterstützt! Der übergebene Dateiname ist außerdem nicht mehr auf MAX_PATH (256-Zeichen) beschränkt und ''\\Servername\Verzeichnis1\MeineDatei.dat'' kann auch als Dateiname übergeben werden.

  • Beachten Sie die Vorbedingungen
  • Diese Funktion ist Bestandteil des Moduls vbzGlobal.bas, das sie hier kostenlos herunterladen können.
#If ANSISupport Then
  Private Declare Function GetFileAttributesA Lib "kernel32" (ByVal lpFileName As String) As Long
  Private Declare Function SetFileAttributesA Lib "kernel32" (ByVal lpFileName As String, _
                           ByVal dwFileAttributes As Long) As Long
#End If
Private Declare Function GetFileAttributesW Lib "kernel32" (ByVal lpFileName As Long) As Long
Private Declare Function SetFileAttributesW Lib "kernel32" (ByVal lpFileName As Long, _
                         ByVal dwFileAttributes As Long) As Long

Public Enum vbzFileAttrib
  FILE_ATTRIBUTE_READONLY = &H1
  FILE_ATTRIBUTE_HIDDEN = &H2
  FILE_ATTRIBUTE_SYSTEM = &H4
  FILE_ATTRIBUTE_VOLUME = &H8           ' Readonly Attribut! do not use with "SetAttr"!
  FILE_ATTRIBUTE_DIRECTORY = &H10
  FILE_ATTRIBUTE_ARCHIVE = &H20
  FILE_ATTRIBUTE_ALIAS = &H40
  FILE_ATTRIBUTE_NORMAL = &H80
  FILE_ATTRIBUTE_TEMPORARY = &H100
  FILE_ATTRIBUTE_REPARSE_POINT = &H400
  FILE_ATTRIBUTE_COMPRESSED = &H800
  FILE_ATTRIBUTE_OFFLINE = &H1000
  FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = &H2000
  FILE_ATTRIBUTE_ENCRYPTED = &H4000
End Enum

Public Function GetAttr(ByVal fName As String) As vbzFileAttrib
  #If ANSISupport Then
    If isUnicode Then
      If Left$(fName, 2) = "\\" Then fName = "UNC\" & Mid$(fName, 3)
      GetAttr = GetFileAttributesW(StrPtr("\\?\" & fName))
    Else
      GetAttr = GetFileAttributesA(fName)
    End If
  #Else
    If Left$(fName, 2) = "\\" Then fName = "UNC\" & Mid$(fName, 3)
    GetAttr = GetFileAttributesW(StrPtr("\\?\" & fName))
  #End If
End Function

Public Function SetAttr(ByVal fName As String, ByVal Attributes As vbzFileAttrib) As Boolean
  #If ANSISupport Then
    If isUnicode Then
      If Left$(fName, 2) = "\\" Then fName = "UNC\" & Mid$(fName, 3)
      SetAttr = CBool(SetFileAttributesW(StrPtr("\\?\" & fName), Attributes))
    Else
      SetAttr = CBool(SetFileAttributesA(fName, Attributes))
    End If
  #Else
    If Left$(fName, 2) = "\\" Then fName = "UNC\" & Mid$(fName, 3)
    SetAttr = CBool(SetFileAttributesW(StrPtr("\\?\" & fName), Attributes))
  #End If
End Function
 

Autor: Ralf Schlegel
Stand: 12/2012

Nach oben

0004 FileLen - auch für Dateien über 4GB (VBA-Overwrite)

Die VBA Funktion FileLen ermittelt die Dateigröße in Bytes und gibt diese als Longwert zurück. Aufgrund des Datentyps Long liegt die erfassbare Grenze bei knapp 4 GByte, was im Zuge der ständig steigenden Multimedia-Dateiqualität oftmals nicht mehr ausreicht! Das hat auch Microsoft erkannt und stellt deshalb bereits seit Windows 2000 die API-Funktion GetFileSizeEx zur Verfügung, die einen LARGE_INTEGER Wert zurückgibt, den wir VB-ler mit dem Datentyp Currency verarbeiten können; zur Erinnerung (Auszug aus der MSDN):
Variablen vom Datentyp Currency werden als 64-Bit-Zahlen (8 Bytes) in einem ganzzahligen Format gespeichert und durch 10.000 dividiert, was eine Festkommazahl mit 15 Vorkomma- und 4 Nachkommastellen ergibt. Diese Darstellung ergibt einen Wertebereich von -922.337.203.685.477,5808 bis 922.337.203.685.477,5807.

Wir deklarieren also die nötigen API-Funktionen und bauen uns eine eigene FileLen Funktion, die die vorhandene VBA-Funktion überschreibt - so müssen wir nichts weiter an unserem Programmcode ändern. Achten Sie aber darauf, das die Variable, die die Dateigröße aufnehmen soll vom Typ Long auf Currency geändert werden muss!

  • Beachten Sie die Vorbedingungen
  • Diese Funktion ist Bestandteil des Moduls vbzGlobal.bas, das sie hier kostenlos herunterladen können.
#If ANSISupport Then
  Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As String, _
          ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
          ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, _
          ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
#End If
Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, _
        ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
        ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, _
        ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetFileSizeEx Lib "kernel32" (ByVal hFile As Long, _
        lpFileSize As Currency) As Boolean
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const GENERIC_READ = &H80000000
Private Const FILE_SHARE_READ = &H1&
Private Const OPEN_EXISTING = &H3

' FileLen: get the file size in bytes (VBA-Overwrite)
Public Function FileLen(ByVal fName As String) As Currency
  Dim fHandle As Long
  Dim fileSize As Currency
  
  #If ANSISupport Then
    If isUnicode Then
      fHandle = CreateFileW(StrPtr(fName), GENERIC_READ, FILE_SHARE_READ, _
                            ByVal 0&, OPEN_EXISTING, 0&, 0&)
    Else
      fHandle = CreateFileA(fName, GENERIC_READ, FILE_SHARE_READ, _
                            ByVal 0&, OPEN_EXISTING, 0&, 0&)
    End If
  #Else
    fHandle = CreateFileW(StrPtr(fName), GENERIC_READ, FILE_SHARE_READ, _
                          ByVal 0&, OPEN_EXISTING, 0&, 0&)
  #End If
  If fHandle > 0 Then
    If GetFileSizeEx(fHandle, fileSize) Then
      FileLen = fileSize * 10000
    End If
    Call CloseHandle(fHandle)
  End If
End Function
Autor: ralf schlegel
Stand: 01/2013

0005 file_properties - der Dialog Dateieigenschaften

Die Dateieigenschaften anzeigen wie im Windows-Explorer mit der Funktion "file_properties". Übergeben Sie der Funktion einfach einen Datei- oder Ordnernamen.

  • Beachten Sie die Vorbedingungen
  • Diese Funktion ist Bestandteil des Moduls vbzGlobal.bas, das sie hier kostenlos herunterladen können.
' file properties:
Private Declare Function ShellExecuteExA Lib "shell32" (ShellExInfo As SHELLEXECUTEINFOA) As Long
Private Type SHELLEXECUTEINFOA
  cbSize As Long
  fMask As Long
  hWnd As Long
  lpVerb As String
  lpFile As String
  lpParameters As String
  lpDirectory As String
  nShow As Long
  hInstApp As Long
  lpIDList As Long
  lpClass As String
  hkeyClass As Long
  dwHotKey As Long
  hIcon As Long
  hProcess As Long
End Type

Private Declare Function ShellExecuteExW Lib "shell32" (ShellExInfo As SHELLEXECUTEINFOW) As Long
Private Type SHELLEXECUTEINFOW
  cbSize As Long
  fMask As Long
  hWnd As Long
  lpVerb As Long
  lpFile As Long
  lpParameters As Long
  lpDirectory As Long
  nShow As Long
  hInstApp As Long
  lpIDList As Long
  lpClass As String
  hkeyClass As Long
  dwHotKey As Long
  hIcon As Long
  hProcess As Long
End Type



Public Sub file_properties(ByVal fName As String)
  Dim ShExInfo As SHELLEXECUTEINFOW         ' Unicode structure

  #If ANSISupport Then                      ' support of ANSI and Unicode
    If isUnicode Then                       ' UNICODE version
      With ShExInfo                         ' fill structure with values...
        .cbSize = Len(ShExInfo)
        .fMask = &H54C
        .hWnd = 0
        .lpVerb = StrPtr("properties")
        .lpFile = StrPtr(fName & Chr$(0))
      End With
      ShellExecuteExW ShExInfo              ' Unicode API call
    Else                                    ' ANSI Version
      Dim ShExInfoA As SHELLEXECUTEINFOA    ' ANSI structure
      With ShExInfoA                        ' fill structure with values...
        .cbSize = Len(ShExInfoA)
        .fMask = &H54C
        .hWnd = 0
        .lpVerb = "properties"
        .lpFile = fName & Chr$(0)
      End With
      ShellExecuteExA ShExInfoA             ' ANSI API call
    End If
  #Else                                     ' support UNICODE ONLY (small and fast code!)
    With ShExInfo                           ' fill structure with values...
      .cbSize = Len(ShExInfo)
      .fMask = &H54C
      .hWnd = 0
      .lpVerb = StrPtr("properties")
      .lpFile = StrPtr(fName & Chr$(0))
    End With
    ShellExecuteExW ShExInfo                ' Unicode API call
  #End If
End Sub
 

Autor: Ralf Schlegel
Stand: 12/2012

Nach oben

0006 CopyFile - eine einzelne Datei kopieren

Die API Funktion CopyFile dient zum Kopieren einer einzelnen Datei und ist schnelle als die VBA interne Function CopyFile.
Da man mit ihr nur eine einzelne Datei kopieren kann, ist sie kein echter Ersatz für das VBA Pendant, hat aber andere Vorteile:

Der folgende Codeabschnitt zeigt die API-Funktion, die neben Unicode auch UNC-Path unterstützt! Der übergebene Dateiname ist außerdem nicht mehr auf MAX_PATH (256-Zeichen) beschränkt und ''\\Servername\Verzeichnis1\MeineDatei.dat'' kann auch als Dateiname übergeben werden.

  • Beachten Sie die Vorbedingungen
  • Diese Funktion ist Bestandteil des Moduls vbzGlobal.bas, das sie hier kostenlos herunterladen können.

 

#If ANSISupport Then
  Private Declare Function CopyFileA Lib "kernel32" (ByVal lpExistingFileName As String, _
          ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
#End If
Private Declare Function CopyFileW Lib "kernel32" (ByVal lpExistingFileName As Long, _
        ByVal lpNewFileName As Long, ByVal bFailIfExists As Long) As Long


' Copy a single file from source to destination; overwrites destination, if it already exists
' If unicode is available 'FileNames' support UNC path and file name lenght up to 23768 chars!
Public Function CopyFile(ByVal srcFileName As String, ByVal dstFileName As String) As Long
  #If ANSISupport Then
    If isUnicode Then
      CopyFile = CopyFileA(srcFileName, dstFileName, 0&)
    Else
      If Left$(srcFileName, 2) = "\\" Then srcFileName = "UNC\" & Mid$(srcFileName, 3)
      If Left$(dstFileName, 2) = "\\" Then dstFileName = "UNC\" & Mid$(dstFileName, 3)
      CopyFile = CopyFileW(StrPtr("\\?\" & srcFileName), StrPtr("\\?\" & dstFileName), 0&)
    End If
  #Else
    If Left$(srcFileName, 2) = "\\" Then srcFileName = "UNC\" & Mid$(srcFileName, 3)
    If Left$(dstFileName, 2) = "\\" Then dstFileName = "UNC\" & Mid$(dstFileName, 3)
    CopyFile = CopyFileW(StrPtr("\\?\" & srcFileName), StrPtr("\\?\" & dstFileName), 0&)
  #End If
End Function
 

Autor: Ralf Schlegel
Stand: 04/2015

Nach oben

0007 CreateFileW - Textdatei lesen und schreiben mit Unicode Support

Die API Funktion CreateFileW dient zum allgemeinen Lesen und Schreiben von Dateien jeglicher Art.
Hier habe ich 2 Funktionen (textFileReadW und textFileWriteW) erstellt, die Sie so in Ihren Code übernehmen können.
Sie erlauben das Lesen und Schreiben von Textdateien mit und ohne Unicode-Inhalt - auch der Dateiname darf dabei Unicode enthalten.
Neben Unicode Dateinamen wird dabei auch UNC-Path unterstützt; der übergebene Dateiname ist daher
nicht mehr auf MAX_PATH (256-Zeichen) beschränkt und ''\\Servername\Verzeichnis1\MeineDatei.dat''
kann auch als Dateiname verwendet werden.

  • Der Funktion "textFileReadW" wird lediglich der Dateiname (incl. Pfad) übergeben.
    Bei erfolgreichem Lesen enthält der Rückgabewert den gesamten Inhalt der Datei.
  • Der Funktion"textFileWriteW" übergeben Sie den Dateinamen und den Text als String, den Sie vorher in Ihrem Code zusammengestellt haben; optional können Sie noch ein Append-Flag setzen, wodurch an einer bereits bestehenden Textdatei der übergebene Text-String angehängt wird. Ohne dieses Flag wird eine bestehende Datei überschrieben.
  • Diese Funktion "isUnicodeString", die in der Funktion "textFileWriteW" benutzt wird, wurde bereits im allgemeinen Abschnitt zu Unicode erläutert.

Private Declare Function CreateFileW Lib "kernel32" (ByVal lpFileName As Long, _
        ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
        ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, _
        ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, _
        ByRef lpFileSizeHigh As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, _
        ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _
        ByVal lpOverlapped As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, _
        ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _
        ByVal lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, _
        ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, _
        ByVal dwMoveMethod As Long) As Long
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1&
Private Const FILE_SHARE_WRITE = &H2&

Private Const CREATE_ALWAYS = &H2
Private Const OPEN_EXISTING = &H3
Private Const OPEN_ALWAYS = &H4&



' ---------------------------------------------------------------------------------------------
Public Function textFileReadW(ByVal fName As String) As String
  Dim hFile As Long     ' file handle
  Dim nBytes As Long    ' number of bytes
  Dim bBytes() As Byte  ' byte buffer (to write)
 
  If InStrB(1, fName, "\\") = 1 Then fName = "UNC\" & Mid$(fName, 3)
  hFile = CreateFileW(StrPtr("\\?\" & fName), GENERIC_READ, FILE_SHARE_READ, _
                      ByVal 0&, OPEN_EXISTING, 0&, 0&)    ' open unicode file name for reading
  If hFile > 0 Then                                       ' if success
    nBytes = GetFileSize(hFile, 0)                        ' get the size
    If nBytes > 0 Then                                    ' if file contains bytes
      ReDim bBytes(nBytes - 1)                            ' create zero based buffer
      ReadFile hFile, bBytes(0), nBytes, nBytes, ByVal 0& ' read whole file at once
      If bBytes(0) = &HFF And bBytes(1) = &HFE Then       ' seems to be unicode
        textFileReadW = Mid$(bBytes(), 2)                 ' ignore the hex "FFFE" bytes
      Else                                                ' else
        textFileReadW = StrConv(bBytes(), vbUnicode)      ' convert buffer to VB unicode string
      End If
    End If
    CloseHandle hFile                                     ' close file
  End If
End Function



' ---------------------------------------------------------------------------------------------
Public Function textFileWriteW(ByVal fName As String, ByVal strText As String, _
                               Optional ByVal txtAppend As Boolean) As Boolean
  Dim hFile As Long     ' file handle
  Dim nBytes As Long    ' number of bytes
  Dim bBytes() As Byte  ' byte buffer (to write)
  Dim uBytes(1) As Byte ' unicode header bytes
 
  If InStrB(1, fName, "\\") = 1 Then fName = "UNC\" & Mid$(fName, 3)
  hFile = CreateFileW(StrPtr("\\?\" & fName), GENERIC_WRITE, _
                      FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                      ByVal 0&, OPEN_ALWAYS, 0&, 0&)      ' open UNICODE file name for writing
  If hFile > 0 Then                                       ' if success
    If isUnicodeString(strText) Then                      ' check if content is UNICODE text
      nBytes = GetFileSize(hFile, 0)                      ' get the file size
      If nBytes = 0 Or Not txtAppend Then                 ' check, if this is a new file
        uBytes(0) = &HFF: uBytes(1) = &HFE                ' create UNICODE textfile header
        WriteFile hFile, uBytes(0), 2, nBytes, 0&         ' write the header bytes
      End If  ' GetFileSize
      bBytes = strText                                    ' copy UNICODE to byte array
    Else
      bBytes = StrConv(strText, vbFromUnicode)            ' convert ANSI to byte array
    End If  ' isUnicodeString
   
    If txtAppend Then                                     ' add to existing text?
      SetFilePointer hFile, 0&, ByVal 0&, FILE_END        ' set file pointer to the end
    End If
    nBytes = UBound(bBytes) + 1                           ' number of bytes to write
    WriteFile hFile, bBytes(0), nBytes, nBytes, 0&        ' write the text (in bytes)
    SetEndOfFile hFile                                    ' mark pos. as "END-Position"
    CloseHandle hFile                                     ' close file
    textFileWriteW = True
  End If  ' hFile > 0
End Function
 

Autor: Ralf Schlegel
Stand: 08/2017

Nach oben