ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE
Diese Seite wurde zuletzt aktualisiert am 30.06.2000

Diese Seite wurde zuletzt aktualisiert am 30.06.2000
Aktuell im ABOUT Visual Basic-MagazinGrundlagenwissen und TechnologienKnow How, Tipps und Tricks rund um Visual BasicActiveX-Komponenten, Controls, Klassen und mehr...AddIns für die Visual Basic-IDE und die VBA-IDEVBA-Programmierung in MS-Office und anderen AnwendungenScripting-Praxis für IE, Windows Scripting Host und das Scripting-ControlTools, Komponenten und Dienstleistungen des MarktesRessourcen für Programmierer (Bücher, Job-Börse)Dies&Das...

Themen und Stichwörter im ABOUT Visual Basic-Magazin
Code, Beispiele, Komponenten, Tools im Überblick, Shareware, Freeware
Ihre Service-Seite, Termine, Job-Börse
Melden Sie sich an, um in den vollen Genuss des ABOUT Visual Basic-Magazins zu kommen!
Informationen zum ABOUT Visual Basic-Magazin, Kontakt und Impressum

Zurück...

Binäre Dateien

Zurück...


Anzeige

Public Enum bfErrorConstants
  bfErrFileAlreadyOpen = vbObjectError + 20000
  bfErrInvalidObject = vbObjectError + 20001
  bfErrFileNotFound = vbObjectError + 20002
  bfErrInvalidFileParam = vbObjectError + 20003
End Enum

Public Enum bfLockConstants
  lockNone     ' 0
  lockShared   ' 1
  lockReadWrite  ' 2
  lockRead     ' 3
  lockWrite    ' 4
End Enum

Public Enum bfVarTypeConstants
  vtInteger = vbInteger  '  2
  vtLong = vbLong      '  3
  vtSingle = vbSingle    '  4
  vtDouble = vbDouble    '  5
  vtCurrency = vbCurrency  '  6
  vtDate = vbDate      '  7
  vtString = vbString    '  8
  vtBoolean = vbBoolean  ' 11
  vtVariant = vbVariant  ' 12
  vtByte = vbByte      ' 17
End Enum

Private mFNr As Long
Private mFSO As New FileSystemObject

Private pFile As File
Private pLock As bfLockConstants

Public Property Get File() As File
  Set File = pFile
End Property

Public Property Get LockMode() As bfLockConstants
  LockMode = pLock
End Property

Public Property Get Path() As String
  If Not (pFile Is Nothing) Then
    Path = pFile.Path
  End If
End Property

Public Sub OpenFile(File As Variant, _
 Optional ByVal LockMode As bfLockConstants, _
 Optional ByVal ForceCreate As Boolean, _
 Optional ByVal OverWrite As Boolean)

  If mFNr Then
    Err.Raise bfErrFileAlreadyOpen, "BinaryFile.OpenFile"
  End If
  If IsObject(File) Then
    If TypeOf File Is File Then
      Set pFile = File
    Else
      Err.Raise bfErrInvalidObject, "BinaryFile.OpenFile"
    End If
  ElseIf VarType(File) = vbString Then
    If mFSO.FileExists(File) Then
      Set pFile = mFSO.GetFile(File)
    Else
      If ForceCreate Then
        On Error Resume Next
        Set pFile = mFSO.CreateTextFile(File, OverWrite)
        If Err.Number Then
          Err.Raise Err.Number, "BinaryFile.OpenFile", _
           Err.Description
        End If
      Else
        Err.Raise bfErrFileNotFound, "BinaryFile.OpenFile", File
      End If
    End If
  Else
    Err.Raise bfErrInvalidFileParam, "BinaryFile.OpenFile"
  End If
  pLock = LockMode
  On Error GoTo OpenFile_Error
  mFNr = FreeFile
  Select Case pLock
    Case lockNone
      Open pFile.Path For Binary As #mFNr
    Case lockShared
      Open pFile.Path For Binary Shared As #mFNr
    Case lockReadWrite
      Open pFile.Path For Binary Lock Read Write As #mFNr
    Case lockRead
      Open pFile.Path For Binary Lock Read As #mFNr
    Case lockWrite
      Open pFile.Path For Binary Lock Write As #mFNr
  End Select
  Exit Sub
  
OpenFile_Error:
  Err.Raise Err.Number, "BinaryFile.OpenFile", Err.Description
End Sub

Public Function GetData(Optional ByVal Position As Long = -1, _
 Optional ByVal VType As bfVarTypeConstants = vtVariant, _
 Optional ByVal Length As Long) As Variant

  Dim nInteger As Integer
  Dim nLong As Long
  Dim nSingle As Single
  Dim nDouble As Double
  Dim nCurrency As Currency
  Dim nDate As Date
  Dim nString As String
  Dim nBoolean As Boolean
  Dim nVariant As Variant
  Dim nByte As Byte
  
  On Error GoTo GetData_Error
  If Position >= 0 Then
    Select Case VType
      Case vtInteger
        Get #mFNr, Position, nInteger
        GetData = nInteger
      Case vtLong
        Get #mFNr, Position, nLong
        GetData = nLong
      Case vtSingle
        Get #mFNr, Position, nSingle
        GetData = nSingle
      Case vtDouble
        Get #mFNr, Position, nDouble
        GetData = nDouble
      Case vtCurrency
        Get #mFNr, Position, nCurrency
        GetData = nCurrency
      Case vtDate
        Get #mFNr, Position, nDate
        GetData = nDate
      Case vtString
        If Length > 0 Then
          nString = Space$(Length)
        Else
          nString = Space$(LOF(mFNr))
        End If
        Get #mFNr, Position, nString
        GetData = nString
      Case vtBoolean
        Get #mFNr, Position, nBoolean
        GetData = nBoolean
      Case vtVariant
        Get #mFNr, Position, nVariant
        GetData = nVariant
      Case vtByte
        Get #mFNr, Position, nByte
        GetData = nByte
    End Select
  Else
    Select Case VType
      Case vtInteger
        Get #mFNr, , nInteger
        GetData = nInteger
      Case vtLong
        Get #mFNr, , nLong
        GetData = nLong
      Case vtSingle
        Get #mFNr, , nSingle
        GetData = nSingle
      Case vtDouble
        Get #mFNr, , nDouble
        GetData = nDouble
      Case vtCurrency
        Get #mFNr, , nCurrency
        GetData = nCurrency
      Case vtDate
        Get #mFNr, , nDate
        GetData = nDate
      Case vtString
        If Length > 0 Then
          nString = Space$(Length)
        Else
          nString = Space$(LOF(mFNr))
        End If
        Get #mFNr, , nString
        GetData = nString
      Case vtBoolean
        Get #mFNr, , nBoolean
        GetData = nBoolean
      Case vtVariant
        Get #mFNr, , nVariant
        GetData = nVariant
      Case vtByte
        Get #mFNr, , nByte
        GetData = nByte
    End Select
  End If
  Exit Function
  
GetData_Error:
  Err.Raise Err.Number, "BinaryFile.GetData", Err.Description
End Function

Public Sub PutData(Value As Variant, _
 Optional ByVal Position As Long = -1, _
 Optional ByVal VType As bfVarTypeConstants = vtVariant)

  Dim nInteger As Integer
  Dim nLong As Long
  Dim nSingle As Single
  Dim nDouble As Double
  Dim nCurrency As Currency
  Dim nDate As Date
  Dim nString As String
  Dim nBoolean As Boolean
  Dim nVariant As Variant
  Dim nByte As Byte
  
  On Error GoTo PutData_Error
  If Position >= 0 Then
    If IsArray(Value) Then
      Put #mFNr, Position, Value
    Else
      Select Case VType
        Case vtInteger
          nInteger = CInt(Value)
          Put #mFNr, Position, nInteger
        Case vtLong
          nLong = CLng(Value)
          Put #mFNr, Position, nLong
        Case vtSingle
          nSingle = CSng(Value)
          Put #mFNr, Position, nSingle
        Case vtDouble
          nDouble = CDbl(Value)
          Put #mFNr, Position, nDouble
        Case vtCurrency
          nCurrency = CCur(Value)
          Put #mFNr, Position, nCurrency
        Case vtDate
          nDate = CDate(Value)
          Put #mFNr, Position, nDate
        Case vtString
          nString = CStr(Value)
          Put #mFNr, Position, nString
        Case vtBoolean
          nBoolean = CBool(Value)
          Put #mFNr, Position, nBoolean
        Case vtVariant
          Put #mFNr, Position, Value
        Case vtByte
          nByte = CByte(Value)
          Put #mFNr, Position, nByte
      End Select
    End If
  Else
    If IsArray(Value) Then
      Put #mFNr, , Value
    Else
      Select Case VType
        Case vtInteger
          nInteger = CInt(Value)
          Put #mFNr, , nInteger
        Case vtLong
          nLong = CLng(Value)
          Put #mFNr, , nLong
        Case vtSingle
          nSingle = CSng(Value)
          Put #mFNr, , nSingle
        Case vtDouble
          nDouble = CDbl(Value)
          Put #mFNr, , nDouble
        Case vtCurrency
          nCurrency = CCur(Value)
          Put #mFNr, , nCurrency
        Case vtDate
          nDate = CDate(Value)
          Put #mFNr, , nDate
        Case vtString
          nString = CStr(Value)
          Put #mFNr, , nString
        Case vtBoolean
          nBoolean = CBool(Value)
          Put #mFNr, , nBoolean
        Case vtVariant
          Put #mFNr, , Value
        Case vtByte
          nByte = CByte(Value)
          Put #mFNr, , nByte
      End Select
    End If
  End If
  Exit Sub
  
PutData_Error:
  Err.Raise Err.Number, "BinaryFile.PutData", Err.Description
End Sub

Public Sub SeekPos(ByVal Position As Long)
  On Error Resume Next
  Seek #mFNr, Position
  If Err.Number Then
    Err.Raise Err.Number, "BinarayFile.SeekPos", Err.Description
  End If
End Sub

Public Sub CloseFile()
  On Error Resume Next
  Close #mFNr
End Sub

Private Sub Class_Terminate()
  CloseFile
End Sub

Zurück zu "Binäre Dateien" Zurück zum Text   


KnowHow-Übersicht

Zum Seitenanfang

Copyright © 1999 - 2017 Harald M. Genauck, ip-pro gmbh  /  Impressum

Zum Seitenanfang

Zurück...

Zurück...

Download Internet Explorer