IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Codes sources à télécharger Pascal Discussion :

REMDIR & MKTREE [Sources]


Sujet :

Codes sources à télécharger Pascal

  1. #1
    Membre émérite
    Avatar de Eric2a
    Homme Profil pro
    Technicien
    Inscrit en
    Septembre 2005
    Messages
    1 225
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 53
    Localisation : France, Corse (Corse)

    Informations professionnelles :
    Activité : Technicien

    Informations forums :
    Inscription : Septembre 2005
    Messages : 1 225
    Points : 2 411
    Points
    2 411
    Par défaut REMDIR & MKTREE
    Deux petits cousins de XDEL : REMDIR et MKTREE.

    REMDIR
    Supprime un répertoire et tous les sous-répertoires qu'il contient
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    REMDIR [/Options] [Lecteur:]Chemin
     
    	[Lecteur:]Chemin   Répertoire(s) à supprimer
     
    	Options :
     
    		/P     Désactive la demande de confirmation avant suppression
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
     
    Uses Dos,Crt;
     
    Var
     Dir:Array[1..16]Of DirStr;
     Z:Byte;
     Rep:ComStr;
     NDir:Word;
     ConfirmFlag:Boolean;
     
    Procedure GetCmd;
    Var
     S:ComStr;
     I:Byte;
     
    Procedure Erreur(Txt:String);
    Begin
     WriteLn(Txt);
     Halt(1);
    End;
     
    Procedure GetSwithes;
    Const
     Swith:Array[1..2]Of Char=('?','P');
     
    Var Z,P:Byte;
     
    Begin
     Delete(S,1,1);
     For Z:=1To Length(S)Do S[Z]:=UpCase(S[Z]);
     For Z:=1To 2Do If S=Swith[Z]Then P:=Z;
     Case P Of
      1:
      Begin
       WriteLn('Supprime un répertoire et tous les sous-répertoires qu''il contient'#13#10);
       WriteLn('REMDIR [/Options] [Lecteur:]Chemin'#13#10);
       WriteLn('       [Lecteur:]Chemin   Répertoire(s) à supprimer');
       WriteLn('Options :'#13#10);
       WriteLn(' /P     Désactive la demande de confirmation avant suppression');
       Halt(1);
      End;
      2:ConfirmFlag:=TRUE;
      Else Erreur('Commutateur non valide - /'+S);
      End;
    End;
     
    Procedure GetDirectory;
    Var
     F:File;
     Attr:Word;
     D:DirStr;
     N:NameStr;
     E:ExtStr;
     
    Begin
     S:=FExpand(S);
     If S[Length(S)]<>'\'Then
         Begin
          Assign(F,S);
          GetFAttr(F,Attr);
          If(DosError=0)And(Attr And Directory<>0)Then S:=S+'\';
         End;
     FSplit(S,D,N,E);
     Inc(NDir);
     Dir[NDir]:=D;
     Dec(Dir[NDir][0]);
    End;
     
    Begin
     If ParamCount=0Then Erreur('Paramètre requis manquant');
     For I:=1To ParamCount Do
         Begin
          S:=ParamStr(I);
          If S[1]='/'Then GetSwithes Else GetDirectory;
         End;
     If NDir=0Then Erreur('Veuillez spécifier le sous-répertoire à supprimer');
    End;
     
    {$I-}
    Procedure RemDir(Const Path:DirStr);
    Var
     DTA:SearchRec;
     Dir:DirStr;
     
    Procedure RDChild(Const P:DirStr);
    Var
     DTA:SearchRec;
     F:File;
     
    Begin
     FindFirst(P+'\*.*',Archive+SysFile+Hidden+ReadOnly,DTA);
     While DosError=0Do
           Begin
            FileMode:=0;
            Assign(F,P+'\'+DTA.Name);
            Reset(F);
            DosError:=IOResult; If DosError<>0Then Exit;
            Close(F);
            DosError:=IOResult; If DosError<>0Then Exit;
            If DTA.Attr And ReadOnly>0Then SetFAttr(F,DTA.Attr Xor ReadOnly);
            If DosError=0Then
               Begin
                Erase(F);
                DosError:=IOResult
               End;
            If DosError<>0Then Exit;
            FindNext(DTA);
           End;
     
     If DosError=18Then
        Begin
         RmDir(P);
         DosError:=IOResult;
        End;
    End;
     
    Begin
     FindFirst(Path+'\*.*',Directory+Hidden,DTA);
     If DosError=3Then Exit;
     While DosError=0Do
           Begin
            If ((DTA.Attr And Directory)>0)And(DTA.Name[1]<>'.')Then
               RemDir(Path+'\'+DTA.Name);
            FindNext(DTA);
           End;
     RDChild(Path);
    End;
     
    Begin
     WriteLn('REMDIR v1.0, Février 1994, Eric GARIDACCI'#13#10);
     GetCmd;
     For Z:=1To NDir Do
         Begin
          Write('Suppression de ',Dir[Z],' ? (O/N) ');
          ReadLn(Rep);
          WriteLn;
          If (Length(Rep)=1)And(UpCase(Rep[1])='O')Then
             Begin
              RemDir(Dir[Z]);
              Write(Dir[Z]);
              If DosError<>0Then Write('  Erreur ',DosError);
              WriteLn;
             End;
         End;
    End.
    MKTREE
    Création de répertoires
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
     
    Uses Dos;
     
    Var Rep:String;
     
    {***********************************************************************}
    {	Renvoie TRUE si Name est un nom de répertoire valide		}
    {***********************************************************************}
     
    Function DirectoryValid(Const Name:String):Boolean;Assembler;
    Var
     TempName:Array[0..255]Of Char;
     
    Asm
    	PUSH	DS
    	LDS	SI,Name
    	LEA	DI,TempName
    	MOV	DX,DI
    	PUSH	SS
    	POP	ES
    	CLD
    	XOR	AH,AH
    	LODSB
    	XCHG	AX,CX
    	REP	MOVSB
    	XOR	AL,AL
    	STOSB
    	PUSH	SS
    	POP	DS
    	MOV	AX,4300H
    	INT	21H
    	MOV	DL,0
    	JB	@@1
    	XOR	AX,AX
    	TEST	CL,Directory
    	JZ	@@1
    	INC	DL
    @@1:	POP	DS
    	MOV	DosError,AX
    	XCHG	AL,DL
    End;
     
    {***********************************************************************}
    {	Création d'un répertoire					}
    {***********************************************************************}
     
    Procedure MakeDirectory(Const Name:String);Assembler;
    Var
     TempName:Array[0..255]Of Char;
     
    Asm
    	PUSH	DS
    	LDS	SI,Name
    	LEA	DI,TempName
    	MOV	DX,DI
    	PUSH	SS
    	POP	ES
    	CLD
    	XOR	AH,AH
    	LODSB
    	XCHG	AX,CX
    	REP	MOVSB
    	XOR	AL,AL
    	STOSB
    	PUSH	SS
    	POP	DS
    	MOV	AH,39H
    	INT	21H
    	JB	@Ret
    	XOR	AX,AX
    @Ret:	POP	DS
    	MOV	DosError,AX
    End;
     
    {***********************************************************************}
    {	Création d'un/de plusieurs répertoire(s) désigné par Name	}
    {***********************************************************************}
     
     
    Procedure WritePath(Const Path:String);Far;
    Begin
     WriteLn(#13,'Création de ',Path)
    End;
     
    Const MkDirProc:Procedure(Const Path:String)=WritePath;
     
    Procedure MakeTree(Var Name:String);Assembler;
    Asm
    	LES	DI,Name
    	CMP	BYTE PTR ES:[DI],1 { Au moins un caractère }
    	JB	@@3
    	PUSH	ES
    	PUSH	DI
    	CALL	DirectoryValid
    	OR	AL,AL
    	JNZ	@@2
    	CMP	DosError,3
    	MOV	DosError,0
    	JNZ	@@2
     
    	LES	DI,Name
    	MOV	AX,ES:[DI]
    	PUSH	AX			{ Sauve la taille de Name }
    	XOR	AH,AH
    	ADD	DI,AX
    	XCHG	AX,CX
    	JCXZ	@@1
    	STD
    	MOV	AL,'\'
    	REPNE	SCASB
    	CLD
    @@1:	LES	DI,Name
    	MOV	BYTE PTR ES:[DI],CL
    	PUSH	ES
    	PUSH	DI
    	CALL	MakeTree
    	LES	DI,Name
    	POP	WORD PTR ES:[DI]	{ Restore la taille de Name }
     
    @@2:	CMP	DosError,0
    	JNZ	@@3
    	LES	DI,Name
    	PUSH	ES
    	PUSH	DI
    	PUSH	ES
    	PUSH	DI
    	CALL	MkDirProc
    	CALL	MakeDirectory
    @@3:
    End;
     
    {***********************************************************************}
    {	Programme principal						}
    {***********************************************************************}
     
    Begin
     WriteLn('MKTREE 1.0, Août 1997, Eric GARIDACCI'#13#10);
     If ParamCount<>1Then
        Begin
         WriteLn('MKTREE répértoire');
         Halt
        End;
     
     Rep:=ParamStr(1);
     
     MakeTree(Rep);
     WriteLn;
     If DosError<>0Then WriteLn('Erreur ',DosError)
    End.

  2. #2
    Responsable Pascal, Lazarus et Assembleur


    Avatar de Alcatîz
    Homme Profil pro
    Ressources humaines
    Inscrit en
    Mars 2003
    Messages
    7 936
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : Belgique

    Informations professionnelles :
    Activité : Ressources humaines
    Secteur : Service public

    Informations forums :
    Inscription : Mars 2003
    Messages : 7 936
    Points : 59 403
    Points
    59 403
    Billets dans le blog
    2
    Par défaut
    Bonjour et merci

    Cette contribution a été ajoutée dans notre application de téléchargements :
    http://pascal.developpez.com/telecha...Borland-Pascal
    Règles du forum
    Cours et tutoriels Pascal, Delphi, Lazarus et Assembleur
    Avant de poser une question, consultez les FAQ Pascal, Delphi, Lazarus et Assembleur
    Mes tutoriels et sources Pascal

    Le problème en ce bas monde est que les imbéciles sont sûrs d'eux et fiers comme des coqs de basse cour, alors que les gens intelligents sont emplis de doute. [Bertrand Russell]
    La tolérance atteindra un tel niveau que les personnes intelligentes seront interdites de toute réflexion afin de ne pas offenser les imbéciles. [Fiodor Mikhaïlovitch Dostoïevski]

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo