Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0711: Alternative Datenströme in einer Datei erstellen und lesen

VB 5/6-Tipp 0711: Alternative Datenströme in einer Datei erstellen und lesen

 von Dario

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetVolumeInformationA (GetVolumeInformation)

Download: Download des Beispielprojektes [3,74 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command5"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Schaltfläche "Command3" auf Frame1
' Steuerelement: Textfeld "txtRead" auf Frame1
' Steuerelement: Schaltfläche "Command2" auf Frame1
' Steuerelement: Textfeld "txtAttach" auf Frame1
' Steuerelement: Beschriftungsfeld "Label2" auf Frame1
' Steuerelement: Beschriftungsfeld "Label1" auf Frame1
' Steuerelement: Schaltfläche "Command1"

Option Explicit

Private Const Filename  As String = "Probe.xyz"
Private Const Attach    As String = "attach.txt"

Private FileExisting    As Boolean


Private Property Get AppPathEx() As String
   AppPathEx = App.Path & IIf(Right$(App.Path, 1) = "\", "", "\")
End Property

Private Sub Command1_Click()
   Dim i As Integer
   
   i = FreeFile
   
   Open AppPathEx & Filename For Output As #i
      Print #i, "So! Hier steht sehr sinnvoller Text."
   Close #i

   FileExisting = True
   Frame1.Enabled = True
   Command1.Enabled = False
   Command5.Enabled = True
End Sub

Private Sub Command2_Click()
   Dim i As Integer
   
   i = FreeFile
   
   Open AppPathEx & Filename & ":" & Attach For Output As #i
      Print #i, txtAttach.Text
   Close #i
   
   txtAttach.Text = ""
   
   Call MsgBox("Anhang geschrieben", 64)
End Sub

Private Sub Command3_Click()
   On Error Goto NoFile
   Dim i As Integer, Buffer As String
   
   i = FreeFile
   
   Open AppPathEx & Filename & ":" & Attach For Input As #i
      Line Input #i, Buffer
   Close #i
   
   txtRead.Text = Buffer
   
   Exit Sub
NoFile:
   Call MsgBox("Es wurden keine Daten angehängt", vbCritical)
End Sub

Private Sub Command5_Click()
   Call Kill(AppPathEx & Filename)
   
   FileExisting = False
   Frame1.Enabled = False
   
   Command1.Enabled = True
   Command5.Enabled = False
End Sub

Private Sub Form_Load()
   ' Fehlerprüfung
   If Not IsValidFileSystem Then
      Call MsgBox("Das Dateisystem muss 'NTFS' oder 'HFS' sein", vbCritical, "Fehler")
      Call Unload(Me)
      
      Set Form1 = Nothing
   End If
   
   FileExisting = False
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--- Anfang Modul "mdlFileSystem" alias mdlFileSystem.bas ---

Option Explicit

' Erforderliche API
Private Declare Function GetVolumeInformation Lib "Kernel32" Alias _
    "GetVolumeInformationA" (ByVal lpRootPathName As String, _
    ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
    lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
    lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
    ByVal nFileSystemNameSize As Long) As Long

' Ist das Dateisystem NTFS
Private Function IsNTFS(ByVal DriveName As String)
   IsNTFS = (GetFileSystemName(DriveName) = "NTFS")
End Function

' Ist das Dateisystem HFS
Private Function IsHFS(ByVal DriveName As String)
   IsHFS = (GetFileSystemName(DriveName) = "HFS")
End Function

' Ist unser Dateisystem für den weiteren Programmablauf in Ordnung?
' Falls DriveName nicht übergeben wurde, wird das aktuelle Laufwerk geprüft
Public Function IsValidFileSystem(Optional ByVal DriveName As String = vbNullString) As Boolean
   IsValidFileSystem = (IsHFS(DriveName) Or IsNTFS(DriveName))
End Function

' Dateisystemnamen auslesen
Private Function GetFileSystemName(ByVal DriveName As String) As String
   Dim Dummy  As String ' Dummy
   Dim FSName As String ' Buffer
   Dim RetVal As Long   ' Rückgabe

   ' Buffer füllen
   FSName = String$(255, Chr$(0))
   
   ' API aufrufen
   RetVal = GetVolumeInformation(DriveName, Dummy, 0&, 0&, 0&, 0&, FSName, 255)
   
   ' Hier gibts ein Problem
   If RetVal = 0 Then
      Call MsgBox("Ein Fehler ist beim Lesen des Dateisystems aufgetreten", _
        vbCritical, "Fehler")
      GetFileSystemName = vbNullString
      Exit Function
   End If

   ' Ausgabe trimmen
   FSName = Strings.Left$(FSName, Strings.InStr(1, FSName, Chr$(0)) - 1)

   GetFileSystemName = Strings.UCase(FSName)
End Function

'---- Ende Modul "mdlFileSystem" alias mdlFileSystem.bas ----
'-------------- Ende Projektdatei Projekt1.vbp --------------