 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
ytwinky
Anmeldungsdatum: 28.05.2005
Beiträge: 2624
Wohnort: Machteburch
|
 Verfasst am: 10.11.2005, 22:06 Titel: Attribute unter FreeBASIC ändern(geändert) |
 |
|
Hi AlleMann,
@programmierer:Paß mal Obacht 
Ich bin mal mutig in die Tiefen der API-Programmierung getaucht!
Herausgekommen ist ein kleines Progrämmchen, das folgendes kann:
-Read/Only-Attribut setzen/löschen
-Hidden-Attribut setzen/löschen
-System-Attribut setzen/löschen
-Archiv-Attribut setzen/löschen
Directory/Compressed/Normal-Bit lassen sich für Programme nicht
sinnvoll einsetzen, also werden sie ausgeblendet..
Ich kann natürlich nicht verhindern, das jemand den Quelltext für
eigene Zwecke ändert und es dennoch probiert:
Seid ruhig mutig und berichtet von den Erfahrungen, ich hab euch gewarnt
Die API-Beschreibungen stammen von:
http://www.activevb.de
und die MsgBox ist der MessageBox von DOSe nicht unähnlich
(Meine Anmerkungen hierzu siehe MessageBox-Thread von fbforum.de)
Die Vereinbahrungen hierzu habe ich in die MsgBox.bi ausgelagert, weil
der Programm-Code sich nur mit den Attributen beschäftigen soll.
| Code: |
Const fbOkOnly = 0 'Nur die Schaltfläche OK anzeigen
Const fbOkCancel = 1 'Schaltflächen OK und Abbrechen anzeigen
Const fbAbortRetryIgnore = 2 'Abbruch, Wiederholen und Ignorieren
Const fbYesNoCancel = 3 'Ja, Nein und Abbrechen
Const fbYesNo = 4 'Schaltflächen Ja und Nein
Const fbRetryCancel = 5 'Schaltflächen Wiederholen und Abbrechen
Const fbCritical = 16 'Stop-Symbol
Const fbQuestion = 32 'Fragezeichen-Symbol
Const fbExclamation = 48 'Ausrufezeichen-Symbol
Const fbInformation = 64 'Information-Symbol
Const fbOK=1 'Rückgabewert OK
Const fbCancel=2 'Rückgabewert Abbrechen
Const fbAbort=3 'Rückgabewert Abbruch
Const fbRepeat=4 'Rückgabewert Wiederholen
Const fbIgnore=5 'Rückgabewert Ignorieren
Const fbYes=6 'Rückgabewert Ja
Const fbNo=7 'Rückgabewert Nein
Const fbNull=0
Declare Function MsgBox Lib "user32" Alias "MessageBoxA" _
(ByVal hWnd As Integer, ByVal lpText As String, _
ByVal lpCaption As String, ByVal wType As Integer) As Integer
|
Die Behandlung der Bits läßt sich sicher anders gestalten, aber ich wollte die
KonstantenNamen benutzen und so ists geworden:
| Code: | '$gui
'Ja, fpp kann das kompilieren, eine andere Möglichkeit wäre fbc -s gui FileAttibutes.Bas, Ergebnis ist genauso ;-))
Option Escape
Option Explicit
'$Include: "MsgBox.Bi"
'siehe MessageBox-Thread auf fbforum.de
'Ich habe die Deklarationen in MsgBox.Bi getan, weil es in diesem Programm nur um Attribute gehen sollte
Const FILE_ATTRIBUTE_READONLY=&H1
Const FILE_ATTRIBUTE_HIDDEN=&H2
Const FILE_ATTRIBUTE_SYSTEM=&H4
Const FILE_ATTRIBUTE_DIRECTORY=&H10
Const FILE_ATTRIBUTE_ARCHIVE=&H20
Const FILE_ATTRIBUTE_NORMAL=&H80
Const FILE_ATTRIBUTE_COMPRESSED=&H800
Declare Function GetFAttr Lib "kernel32.dll" Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long
Declare Function SetFileAttribute Lib "kernel32.dll" Alias "SetFileAttributesA" _
(ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Declare Function EvalAttr(Attr As Long) As String
Sub SetFattr(ByRef DateiName As String, ByRef Attr)
'It's no good idea to set bits higher than archive with a program,
'because windows uses them for its own purposes, so they are faded out..
SetFileAttribute DateiName, (GetFAttr(DateiName) And &HFF00)+(Attr And &H2F)
End Sub
Sub ChkBitNew(ByVal FileName As String, ByVal Which As String, WhichBit As Long, ByRef Attr As Long)
Dim i
i=MsgBox(fbNull, Which+"\nJa=Setze Bit\nNein=Lösche Bit\nCancel=Nix Ändern", FileName &" " &EvalAttr(Attr), fbYesNoCancel+fbQuestion)
Select Case i
Case fbYes: Attr=Attr+WhichBit*IIF((Attr And WhichBit)=0, 1, 0)
Case fbNo: Attr=Attr-WhichBit*IIF((Attr And WhichBit)<>0, 1, 0)
Case Else: 'leave Bit as it is..
End Select
End Sub
Function EvalAttr(Attr As Long) As String
Dim b$
If Attr And FILE_ATTRIBUTE_READONLY Then b$=b$+" R"
If Attr And FILE_ATTRIBUTE_HIDDEN Then b$=b$+" H"
If Attr And FILE_ATTRIBUTE_SYSTEM Then b$=b$+" S"
If Attr And FILE_ATTRIBUTE_ARCHIVE Then b$=b$+" A"
If Attr And FILE_ATTRIBUTE_DIRECTORY Then b$=b$+" D"
If Attr And FILE_ATTRIBUTE_NORMAL Then b$=b$+" N"
If Attr And FILE_ATTRIBUTE_COMPRESSED Then b$=b$+" C"
Function=b$
End Function
Dim As Long Attr
Dim As String FileName
Dim M$(1), s$
M$(0)="Nein"
M$(1)="Ja"
FileName=Environ$("Tmp")+"\\Test.All"
s$="Eintrag : "+FileName
Attr=GetFAttr(FileName)
If Attr>=0 Then
s$=s$+"\nAttribut(ald):"+Hex$(Attr)+EvalAttr(Attr)+"\n"
ChkBitNew FileName, "Setze NurLesen-Bit?", FILE_ATTRIBUTE_READONLY, Attr
ChkBitNew FileName, "Setze Versteckt-Bit?", FILE_ATTRIBUTE_HIDDEN, Attr
ChkBitNew FileName, "Setze System-Bit?", FILE_ATTRIBUTE_SYSTEM, Attr
ChkBitNew FileName, "Setze Archiv-Bit?", FILE_ATTRIBUTE_ARCHIVE, Attr
SetFAttr FileName, Attr
Attr=GetFAttr(FileName)
s$=s$+"\nAttribut(neu):" &(Hex$(Attr)) &EvalAttr(Attr)
Else
s$=s$ &" nicht gefunden.. " &Attr
End If
MsgBox fbNull, s$, "Admin-Info", fbExclamation
'Sleep 'wird nur benötigt, wenn das Programm nicht mit '$gui (bei fpp) oder fbc -s gui FileAttribute.Bas (bei fbc) kompiliert wird
End |
Ich habe diesen Code unter FB0.15b vom 26.10.2005 getestet und nur an Einträgen, die
ich extra dafür angelegt habe, bei diesen funktionierts
Bis denn denn und viele Grüße
ytwinky
[Edit]Das Hauptprogramm bietet nun nicht mehr an, Attribute von nicht vorhandenen Einträgen zu bearbeiten..
..hier nun die versprochenene Exists-Function: | Code: | Option Explicit
Declare Function GetFAttr Lib "kernel32.dll" Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long
Declare Function Exists(FileName As String) As Long
Declare Function FileExists(FileName As String) As Long
Declare Function ExistsFolder(FileName As String) As Long
Function Exists(FileName As String) As Long
Const DIRECTORY_BIT=&H04
Dim Attribut=GetFAttr(FileName)
Function=IIF(Attribut<0, 0, Bit(Attribut, DIRECTORY_BIT)+2)
'2=Datei vorhanden, 1=Directory vorhanden, 0=Nix gefunden
End Function
Function FileExists(FileName As String) As Long
Function=Exists(FileName)=2
End Function
Function FolderExists(FolderName As String) As Long
Function=Exists(FolderName)=1
End Function
Sub Bewerte(ByVal FileName As String)
?FileName &"=>" &Exists(FileName)
?"Datei gibt es ";
If Not FileExists(FileName) Then ?"nicht" Else ?
?"Directory gibt es ";
If Not FolderExists(FileName) Then ?"nicht" Else ?
End Sub
Dim As String FileName
Bewerte(Environ$("Tmp") &"\\Test.All")
Bewerte(Environ$("Tmp") &"\\Test1.All")
Bewerte(Environ$("Tmp") &"\\TestZ.All")
?"..und eine Garantie gibt es sowieso nicht..;-))"
?"l„uft unter FB0.15b"
Sleep |
Hat ein büschen gedauert, läuft aber..
Grüße
ytwinky
_________________
| v1ctor hat Folgendes geschrieben: | | Yeah, i like INPUT$(n) as much as PRINT USING.. |
..also ungefähr so, wie ich GOTO..
Zuletzt bearbeitet von ytwinky am 10.12.2005, 19:48, insgesamt 2-mal bearbeitet |
|
| Nach oben |
|
 |
Michael712
aka anfänger, programmierer
Anmeldungsdatum: 26.03.2005
Beiträge: 1593
|
| Verfasst am: 22.11.2005, 18:01 Titel: |
|
|
Hey, cool!!
Danke!
Hab ich garnicht gesehen. Habe auch ne andere sehr schlechte Variante gefunden, mit shell "attrib blabla". Aber deine Variante ist genau das, was ich gesucht habe. Klappt perfekt.
Nochmal THX für die Mühe.
Michael |
|
| Nach oben |
|
|
ytwinky
Anmeldungsdatum: 28.05.2005
Beiträge: 2624
Wohnort: Machteburch
|
| Verfasst am: 23.11.2005, 18:14 Titel: |
|
|
Hi programmierer,
äääh, wenn ich ehrlich sein soll, habe ich das eher für mich gemacht
Daß da nebenbei für dich eine brauchbare Lösung entsteht, war ein erwünschter Nebeneffekt..
Aber deine Rückmeldung freut mich!
Viele Grüße
ytwinky
_________________
| v1ctor hat Folgendes geschrieben: | | Yeah, i like INPUT$(n) as much as PRINT USING.. |
..also ungefähr so, wie ich GOTO.. |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
