Rubrik: Dateisystem · Dateien allgemein | VB-Versionen: VB6 | 09.05.11 |
Erweiterte Dateiattribute VBA 'GetAttr' und 'SetAttr' auf den Stand der Technik bringen | ||
Autor: Ralf Schlegel | Bewertung: | Views: 11.015 |
www.vb-zentrum.de | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | kein Beispielprojekt |
Warum auch immer: die VBA Funktionen GetAttr und SetAttr scheinen spätestens ab Windows Vista hin und wieder Probleme zu bereiten. Erst recht, wenn sie im Batch (mehrer Dateien hintereinander) benutzt werden. Ausserdem 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 zusätzlich noch UNICODE und UNC-Path unterstützt! D.h.: der übergebene Dateiname ist nicht mehr auf MAX_PATH (256-Zeichen) beschränkt und '\\Servername\Verzeichnis1\MeineDatei.dat' kann auch als Dateiname übergeben werden. Kopieren Sie den nachfolgenden Code in ein beliebiges Projektmodul.<(ü>
Das war's dann auch schon, da die Public Funktionsnamen und Parameter in diesem Code mit denen des VBA identisch sind, werden die alten VBA-Funktionen praktisch überschrieben bzw. ignoriert und Sie müssen an Ihrem vorhandenen Projekt keinerlei weiter Änderungen vornehmen! - Das Leben kann so einfach sein...
Option Explicit 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 Declare Function SetFileAttributesA Lib "kernel32" ( _ ByVal lpFileName As String, _ ByVal dwFileAttributes As Long) As Long Private Declare Function SetFileAttributesW Lib "kernel32" ( _ ByVal lpFileName As Long, _ ByVal dwFileAttributes As Long) As Long Private Declare Function GetVersionEx Lib "kernel32" _ Alias "GetVersionExA" ( _ lpVersionInformation As OSVERSIONINFO) As Long ' Typendefinition Betriebssystem 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_WIN32s = 0 Private Const VER_PLATFORM_WIN32_WINDOWS = 1 Private Const VER_PLATFORM_WIN32_NT = 2 Public Enum vbzFileAttrib FILE_ATTRIBUTE_READONLY = &H1 FILE_ATTRIBUTE_HIDDEN = &H2 FILE_ATTRIBUTE_SYSTEM = &H4 FILE_ATTRIBUTE_VOLUME = &H8 ' Readonly Attribut! Nicht in SetAttr verwenden! 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 #If False Then Const FILE_ATTRIBUTE_READONLY = &H1 Const FILE_ATTRIBUTE_HIDDEN = &H2 Const FILE_ATTRIBUTE_SYSTEM = &H4 Const FILE_ATTRIBUTE_VOLUME = &H8 Const FILE_ATTRIBUTE_DIRECTORY = &H10 Const FILE_ATTRIBUTE_ARCHIVE = &H20 Const FILE_ATTRIBUTE_ALIAS = &H40 Const FILE_ATTRIBUTE_NORMAL = &H80 Const FILE_ATTRIBUTE_TEMPORARY = &H100 Const FILE_ATTRIBUTE_REPARSE_POINT = &H400 Const FILE_ATTRIBUTE_COMPRESSED = &H800 Const FILE_ATTRIBUTE_OFFLINE = &H1000 Const FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = &H2000 Const FILE_ATTRIBUTE_ENCRYPTED = &H4000 #End If
Private Function isUnicode() As Boolean ' Prüft auf NT (Unicode)-Betriebssysteme: ' True bei NT/2000/XP/Vista/Win7, sonst False Dim info As OSVERSIONINFO info.dwOSVersionInfoSize = Len(info) GetVersionEx info isUnicode = (info.dwPlatformId = VER_PLATFORM_WIN32_NT) End Function
Public Function GetAttr(ByVal fName As String) As vbzFileAttrib If isUnicode Then If Left$(fName, 2) = "\\" Then fName = "UNC\" & Mid$(fName, 3) GetAttr = GetFileAttributesW(StrPtr("\\?\" & fName)) Else GetAttr = GetFileAttributesA(fName) End If End Function
Public Function SetAttr(ByVal fName As String, _ ByVal Attributes As vbzFileAttrib) As Boolean 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 End Function
P.S.: die "isUnicode" Abfrage können Sie getrost entfernen, wenn Ihre Applikation ohnehin nur für Win2K und neuer gedacht ist!
Verwenden Sie dann nur die Unicode Varianten (GetFileAttributesW / SetFileAttributesW), löschen die ELSE-Bedingungen und entfernen die Betriebssystem-Abfrage.