AW: Passwortgeschützte Datei überspringen
05.04.2008 12:53:15
Nepumuk
Hallo Günter
mal ein Beispiel:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public Sub test()
MsgBox IsFileProtect("C:\Test.xls")
End Sub
Private Function IsFileProtect(strFilePath As String) As Boolean
Dim intFreeFile As Integer
Dim lngRowPosition As Long, lngPosBOF() As Long, lngCounter As Long
Dim lngCountBOF As Long, lngFindBOF As Long, lngFindDBCell As Long
Dim lngRecordLength As Long, lngFilePosition As Long
Dim strRowString As String, strDBCellString As String, strBOFString As String
Dim strBuffer As String
Dim bytBuffer() As Byte
On Error Resume Next
Redim lngPosBOF(1 To 10)
strBOFString = Chr$(9) & Chr$(8) & Chr$(16) & Chr$(0)
strDBCellString = Chr$(&HD7) & Chr$(0)
strRowString = Chr$(&H8) & Chr$(&H2) & Chr$(&H10)
intFreeFile = FreeFile
Open strFilePath For Binary Access Read As #intFreeFile
strBuffer = String$(LOF(intFreeFile), 0)
Get #intFreeFile, , strBuffer
Close #intFreeFile
lngFindBOF = InStr(1, strBuffer, strBOFString)
Do While lngFindBOF
lngCountBOF = lngCountBOF + 1
If lngCountBOF > UBound(lngPosBOF) Then _
Redim Preserve lngPosBOF(1 To UBound(lngPosBOF) + 10)
lngPosBOF(lngCountBOF) = lngFindBOF
lngFindBOF = InStr(lngFindBOF + 1, strBuffer, strBOFString)
Loop
Redim Preserve lngPosBOF(1 To lngCountBOF)
Do
lngFindDBCell = lngFindDBCell + 1
lngFindDBCell = InStr(lngFindDBCell, strBuffer, strDBCellString)
If lngFindDBCell = 0 Then Exit Do
If lngFindDBCell > lngPosBOF(1) Then Exit Do
bytBuffer = StrConv(Mid$(strBuffer, lngFindDBCell + 4, 2), vbFromUnicode)
lngRowPosition = lngFindDBCell - FileDwToLong(bytBuffer(0), bytBuffer(1))
If InStr(lngRowPosition, strBuffer, strRowString) = lngRowPosition Then
Exit Do
Else
lngRowPosition = 0
End If
Loop
For lngCounter = 1 To UBound(lngPosBOF)
bytBuffer = StrConv(Mid$(strBuffer, _
lngPosBOF(lngCounter) + 6, 1), vbFromUnicode)
If (bytBuffer(0) And 5) = 5 Then Exit For
Next
lngFilePosition = lngPosBOF(lngCounter)
Do
bytBuffer = StrConv(Mid$(strBuffer, lngFilePosition + 2, 2), vbFromUnicode)
Err.Clear
lngRecordLength = FileDwToLong(bytBuffer(0), bytBuffer(1)) + 5
bytBuffer = StrConv(Mid$(strBuffer, lngFilePosition - 1, _
lngRecordLength), vbFromUnicode)
If Err.Number <> 0 Then Exit Do
If (bytBuffer(1) = 0) And (bytBuffer(2) = 0) Then Exit Do
If (bytBuffer(1) = 255) And (bytBuffer(2) = 255) Then Exit Do
If bytBuffer(1) = &H13 Then
IsFileProtect = GetTextFromRecord(bytBuffer) <> "00"
Exit Function
End If
lngFilePosition = lngFilePosition + lngRecordLength - 1
If bytBuffer(1) = &HA Then
lngCounter = lngCounter + 1
If lngCounter > UBound(lngPosBOF) Then Exit Do
lngFilePosition = lngPosBOF(lngCounter)
End If
Loop
End Function
Private Function FileDwToLong(ByVal ByteLeft As Byte, ByVal ByteRight As Byte) As Long
FileDwToLong = Clng(ByteRight) * Clng(256) + Clng(ByteLeft)
End Function
Private Function GetTextFromRecord(bytRecord() As Byte) As String
Dim lngCounter As Long, lngEnd As Long, lngRecordLength As Long
lngRecordLength = FileDwToLong(bytRecord(3), bytRecord(4))
If lngRecordLength = 0 Then Exit Function
If lngRecordLength = 2 Then
GetTextFromRecord = Hex$(bytRecord(5)) & Hex$(bytRecord(6))
Exit Function
Else
lngEnd = FileDwToLong(bytRecord(5), bytRecord(6)) + 7
For lngCounter = 8 To lngEnd
GetTextFromRecord = GetTextFromRecord & Chr$(bytRecord(lngCounter))
Next
End If
End Function
Gruß
Nepumuk