AW: Feststellen ob Arbeitsmappe geschützt ist
06.05.2009 08:09:54
Tino
Hallo,
kannst mal testen ob es funktioniert.
Dieser Geniale Code stammt nicht von mir, dieser ist von Nepumuk.
Option Explicit
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
Public Sub BeispielVerwendung()
If IsFileProtect("J:\1 Forum\Beispiel.xls") Then
MsgBox "Datei ist geschützt"
Else
MsgBox "Datei ist nicht geschützt"
End If
End Sub
Gruß Tino