vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevAniGif - als kostenlose Vollversion auf unserer vb@rchiv CD Vol.5  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Dateisystem · Dateien allgemein   |   VB-Versionen: VB609.05.11
Erweiterte Dateiattribute

VBA 'GetAttr' und 'SetAttr' auf den Stand der Technik bringen

Autor:   Ralf SchlegelBewertung:     [ Jetzt bewerten ]Views:  11.015 
www.vb-zentrum.deSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11kein 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.

Dieser Tipp wurde bereits 11.015 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Aktuelle Diskussion anzeigen (2 Beiträge)

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel