FORUM DE DISCUSSION SUR LE LANGAGE PANORAMIC

Développement d'applications avec le langage Panoramic
 
AccueilAccueil  FAQFAQ  RechercherRechercher  S'enregistrerS'enregistrer  MembresMembres  GroupesGroupes  Connexion  
Derniers sujets
» Panoramic et ses curiosités
par Jack Aujourd'hui à 8:15

» Synedit Parameters
par Klaus Aujourd'hui à 1:33

» Utilitaire de suppression de fichiers
par Yannick Hier à 23:03

» Code à vérifier SVP (Oups ! résolu)
par Jean Claude Jeu 22 Juin 2017 - 21:16

» Compilateur FBPano
par jean_debord Jeu 22 Juin 2017 - 9:56

» Bienvenue à Virtualalan !
par UltraVox Jeu 22 Juin 2017 - 9:18

» Concours de Morpions
par jjn4 Jeu 22 Juin 2017 - 0:04

» ShortName$(F) [Cloturé]
par papydall Mer 21 Juin 2017 - 16:19

» Remplacer espace par tiret dans noms des dossiers / fichiers
par papydall Mer 21 Juin 2017 - 15:27

» Menu personalisé avec icones et menu contextuel
par Laurent (Minibug) Mer 21 Juin 2017 - 12:44

» La liste des choses à faire ...
par Jack Mar 20 Juin 2017 - 22:49

» Quoi de neuf à propos de Goric 3D ? (@Jack)
par UltraVox Mar 20 Juin 2017 - 21:06

» Nom court et anti fenetre dos
par silverman Mar 20 Juin 2017 - 18:31

» Ludothèque Panoramic
par jjn4 Mar 20 Juin 2017 - 18:09

» Proposition à la communauté
par Yannick Mar 20 Juin 2017 - 15:02

Navigation
 Portail
 Index
 Membres
 Profil
 FAQ
 Rechercher
Rechercher
 
 

Résultats par :
 
Rechercher Recherche avancée
Juin 2017
LunMarMerJeuVenSamDim
   1234
567891011
12131415161718
19202122232425
2627282930  
CalendrierCalendrier

Partagez | 
 

 Gestionnaire d'une librairie de fichiers

Voir le sujet précédent Voir le sujet suivant Aller en bas 
AuteurMessage
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Gestionnaire d'une librairie de fichiers   Mar 26 Jan 2016 - 21:43

Je me suis amusé à réaliser un gestionnaire de librairies de fichiers. L'idée était de créer et gérer un fichier binaire dans lequel on puisse ranger tout type de fichiers, afin de pouvoir distribuer un lot entier de fichiers mais sous forme d'un seul fichier physique.

Vous me demanderez à quoi ça sert, étant donné qu'on a maintenant les commandes ARCHIVE_xxx dans Panoramic ? Pour deux raisons:
1. relever le défi technique, pour le plaisir
2. offrir autre chose que la gestion ARCHIVE de Panoramic

Le point (1) - ça ne se discute pas - c'est vraiment pour mon plaisir.

Le point (2) est plus intéressant. En effet, les commandes ARCHIVE travaillent sur un dossier entier, soit en archivage, soit en restauration. Pas question de faire du sélectif, même (et surtout !) et extraction. Et ce sont des fichiers ZIP, certes gérés partout par l'outil ZIP ou similaire, mais justement pas manipulable en profondeur par Panoramic. C'est très bien que ça existe, ça résout pas mal de problèmes, mais je voulais quelque chose de plus souple.

J'ai donc conçu un format "propriétaire" très simple, adapté à mon propos. En gros, il s'agit d'un fichier binaire dont les 3 premiers mots constituent une mini-entête ("identifiant", et un nombre de segments dans le fichier), suivi d'un "segment" par fichier mémorisé. Chaque segment est lui-même constitué d'une entête contenant un identifiant, la longueur totale du segment, la longueur du nom du fichier et le nom du fichier (terminé par un octet 0), suivi des données du fichier réel.

Toute une série d'opérations sont réalisées sur ce type de fichier librairie. Elles sont réparties en deux groupes, correspondant à des titres de menu: "Fichier" et "Segment". Je vous laisse découvrir ces différentes fonctions. La documentation complète est dans le source.

Juste un dernier mot: cette librairie peut contenir n'importe quoi: du texte, des images, des exécutables... Ce sont simplement des fichiers.

Voici le source:
Code:
' FileLibrary.bas

' Ce programme gère une librarie de fichiers qui a la structure suivante:
'   #KGF
'   FLIB
'   ntot (nombre total de fichiers)
'   seg 1
'   ...
'   seg ntot
' Chaque segment a la structure:
'   #SEG  ou  #DEL
'   nseg
'   lseg (longueur totale du segment sauf les deux premiers mots)
'   snom (longeur du nom)
'   nom (nom en ascii, terminé par un 0)
'   données du segment (de longueur lseg-snom-4)
'
' Opérations:
'   création librairie vide                         ok
'   ouvrir une librairie existante                  ok
'   fermer la librairie en cours                    ok
'   enregistrer la librairie sous un autre nom      ok
'   ajouter un segnement en fin de librarie         ok
'   supprimer d'un segment                          ok
'   localiser le segment numéro n                   ok
'   localiser le segment de nom x                   ok
'   extraire le segment localisé                    ok
'   restaurer un segment supprimé                   ok
'   donner la liste des segments de la librairie    ok
'   purger la liste des segments supprimés          ok
'
' Les opérations se font sur un fichier temporaire.
' L'opération Enregistrer retourne au nom de fichier initial.
'
' La suppression d'un segment se fait en remplaçant simplement
' le marqueur du segment par #DEL. Ainsi, le contenu peut
' être récupéré.

  constantes()
  variables()
  labels()

  form0()
  menus()
  
  dll()

  invisibles()
  
  initialisations()

  end
  
sortir:
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Sortir quand-même ?")<>1 then return
  end_if
  res% = dll_call1("KillProcessByHandle",handle(0))
  ' fini ici...
  
nouveau:
  nouveau()
  return
  
fermer:
  fermer()
  return
  
ouvrir:
  ouvrir()
  return
  
enregistrer:
  enregistrer()
  return

enregistrersous:
  enregistrersous()
  return
  
ajouter:
  ajouter()
  return
  
supprimer:
  supprimer()
  return
  
restaurer:
  restaurer()
  return
  
extraire:
  extraire()
  return

purger:
  purger()
  return
  
sub form0()
  caption 0,titre$
  list 101 : full_space 101 : ' width 101,200 : height 101,400
end_sub

sub constantes()
  dim kgf$ : kgf$ = "KGF.dll"
  dim NomDeTravail$ : NomDeTravail$ = dir_current$ + "\KgfFilLib_temp.kfl"
  dim titre$ : titre$ = "Librairie de fichiers"
end_sub

sub variables()
  dim res%
  dim NomDeLibrairie$, NomDeSegment$
  dim NombreDeSegments%, SegmentActuel%, AdresseActuelle%, LongueurSegment%
  dim FlagModification%, FlagOpen%
end_sub

sub dll()
  dll_on kgf$
end_sub

sub labels()
  label sortir, nouveau, fermer, ouvrir, enregistrer, enregistrersous
  label ajouter, supprimer, extraire, restaurer, purger
end_sub

sub menus()
  main_menu 1
  
  sub_menu 2 : parent 2,1 : caption 2,"Fichier"
    sub_menu 21 : parent 21,2 : caption 21,"Nouveau" : on_click 21,nouveau
    sub_menu 22 : parent 22,2 : caption 22,"Ouvrir..." : on_click 22,ouvrir
    sub_menu 23 : parent 23,2 : caption 23,"Fermer" : on_click 23,fermer
    sub_menu 24 : parent 24,2 : caption 24,"Enregistrer" : on_click 24,enregistrer
    sub_menu 25 : parent 25,2 : caption 25,"Enregistrer sous..." : on_click 25,enregistrersous
    sub_menu 26 : parent 26,2 : caption 26,"-"
    sub_menu 27 : parent 27,2 : caption 27,"Sortir" : on_click 27,sortir

  sub_menu 3 : parent 3,1 : caption 3,"Segment"
    sub_menu 31 : parent 31,3 : caption 31,"Ajouter" : on_click 31,ajouter
    sub_menu 32 : parent 32,3 : caption 32,"Supprimer" : on_click 32,supprimer
    sub_menu 33 : parent 33,3 : caption 33,"Extraire" : on_click 33,extraire
    sub_menu 34 : parent 34,3 : caption 34,"Restaurer" : on_click 34,restaurer
    sub_menu 35 : parent 35,3 : caption 35,"-"
    sub_menu 36 : parent 36,3 : caption 36,"Purger" : on_click 36,purger



end_sub

sub invisibles()
  open_dialog 1000
  save_dialog 1001
  dlist 1101             : ' liste des adresses des segments
  dlist 1102             : ' liste des longueurs des segments
  dlist 1103             : ' liste des adresses des données des segments
  dlist 1104             : ' liste des longueurs des données des segments
end_sub

sub initialisations()
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
end_sub

sub nouveau()
  dim_local buf$, n%
  if FlagModification%=1
    if message_confirmation_yes_no("Une modification est en cours. Créer quand-même ?")<>1 then exit_sub
  end_if
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  res% = dll_call1("CreateBinaryFile",adr(NomDeTravail$))
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(NomDeTravail$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  n% = 0
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,9,0)
  FlagModification% = 1
  NomDeLibrairie$ = ""
  FlagOpen% = 1
  caption 0,"<nouveau> - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
  NombreDeSegments% = 0
end_sub

sub fermer()
  dim_local nom$
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Enregistrer ?")<>1 then exit_sub
    if NomDeLibrairie$=""
      filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
      nom$ = file_name$(1001)
      if nom$="_" then exit_sub
      if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
      if file_exists(nom$)=1
        if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
      end_if
      NomDeLibrairie$ = nom$
    end_if
    res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
    if file_exists(NomDeLibrairie$)=1 then file_delete NomDeLibrairie$
    file_rename NomDeTravail$,NomDeLibrairie$
    FlagOpen% = 0
    NomDeLibrairie$ = ""
    caption 0,titre$
    FlagModification% = 0
    FlagOpen% = 0
    clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
    NombreDeSegments% = 0
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  NomDeLibrairie$ = ""
  caption 0,titre$
  FlagModification% = 0
  FlagOpen% = 0
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
  NombreDeSegments% = 0
end_sub

sub ouvrir()
  dim_local nom$, buf$, i%
  if FlagModification%=1
    message "Une modification est en cours. Veuillez fermer le fichier."
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 0
  caption 0,titre$
  filter 1000,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=0
    message "Fichier non trouvé."
    exit_sub
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  buf$ = string$(8," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(nom$),8,1,adr(buf$))
  res% = dll_call1("CloseBinaryFile",adr(nom$))
  if buf$<>"#KGFFLIB"
    message "Pas une librairie valide."
    exit_sub
  end_if
  NomDeLibrairie$ = nom$
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  file_copy NomDeLibrairie$,NomDeTravail$
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 1
  FlagModification% = 0
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
end_sub

sub enregistrer()

end_sub

sub enregistrersous()
  dim_local nom$
  filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  NomDeLibrairie$ = nom$
  FlagOpen% = 1
  FlagModification% = 1
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  file_copy NomDeTravail$,NomDeLibrairie$
end_sub

sub ChercherPremierSegment()
  dim_local n%, a%, nom$, lnom%, prefix$
  prefix$ = ""
  res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,9)
  NombreDeSegments% = n%
  SegmentActuel% = 0
  if NombreDeSegments%>0
    SegmentActuel% = 1
    AdresseActuelle% = 13 : ' dépasser les 3 mots d'entête
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL")
      message "Librairie invalide - identifiant du premier segment"
      exit_sub
    end_if
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>1
      message "Librairie invalide - numéro du premier segment"
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if nom$="#DEL" then prefix$ = "<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    item_add 101,prefix$+" "+file_extract_name$(nom$)
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
  end_if
end_sub

'   #SEG
'   nseg
'   lseg (longueur totale du segment sauf les deux premiers mots)
'   snom (longeur du nom)
'   nom (nom en ascii, terminé par un 0)
'   données du segment (de longueur lseg-snom-4)
sub ChercherSegmentSuivant()
  dim_local n%, a%, nom$, lnom%, prefix$
  prefix$ = ""
  if SegmentActuel%=NombreDeSegments% then exit_sub
  AdresseActuelle% = AdresseActuelle% + 8 + LongueurSegment%
  SegmentActuel% = SegmentActuel% + 1
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL")
      message "Librairie invalide - identifiant du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>SegmentActuel%
      message "Librairie invalide - numéro du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if nom$="#DEL" then prefix$ ="<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    item_add 101,prefix$+" "+file_extract_name$(nom$)
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
end_sub

sub ajouter()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  filter 1000,"Textes |*.txt|Images|*.bmp;*.jpg;*.png|Tous|*.*"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if file_exists(nom$)=0
    message "Fichier introuvable"
    exit_sub
  end_if
  nom1$ = file_extract_name$(nom$)
  if count(101)>0
    for i%=1 to count(101)
      if nom1$=item_read$(101,i%)
        message "Fichier déjà présent dans la librairie"
        exit_sub
      end_if
    next i%
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  siz0% = dll_call1("GetBinaryFileSize",adr(NomDeTravail$))
  siz1% = dll_call1("GetBinaryFileSize",adr(nom$))
  NombreDeSegments% = NombreDeSegments% + 1
  SegmentActuel% = NombreDeSegments%
  ' installer le marqueur "#SEG"
  AdresseActuelle% = siz0% + 1
  item_add 101,nom1$
  item_add 1101,str$(AdresseActuelle%)
  s$ = "#SEG"
' message "Ajout #SEG"
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "c"
  ' installer le numéro du nouveau segment
  a% = AdresseActuelle% + 4
  n% = SegmentActuel%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "d"
  ' installer la longueur du segment
  a% = a% + 4
  n% = 4 + 4 + len(nom1$)+1 + siz1%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
    item_add 1102,str$(n%)
    item_add 1104,str$(siz1%)
' message "e"
  ' installer la longueur du nom
  a% = a% + 4
  n% = len(nom1$) + 1
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "f"
  ' installer le nom du segment
  a% = a% + 4
  s$ = nom1$ + chr$(0)
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "g"
  ' installer les données du segment
  a% = a% + len(nom1$) + 1
  s$ = string$(siz1%," ")
  item_add 1103,str$(a%)
  res% = dll_call2("ReadBinaryFileToString",adr(nom$),adr(s$))
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "h"
  ' mettre le nombre total de segments à jour
  a% = 9
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(NombreDeSegments%),4,a%,0)
  FlagModification% = 1
' message "i"
  res% = dll_call1("CloseBinaryFile",adr(nom$))
end_sub

sub supprimer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment supprimer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  v% = asc("#")+asc("D")*256+asc("E")*256*256+asc("L")*256*256*256
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,"<supprimé>"
  FlagModification% = 1
end_sub

sub extraire()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, buf$, lseg%, aseg%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment extraire le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  LongueurSegment% = val(item_read$(1102,ind%))
  aseg% = val(item_read$(1103,ind%))
  lseg% = val(item_read$(1104,ind%))
  buf$ = string$(LongueurSegment%," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lseg%,aseg%,adr(buf$))
  filter 1001,""
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier déjà existant. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  res% = dll_call2("WriteStringToBinaryFile",adr(nom$),adr(buf$))
end_sub

sub restaurer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")<>1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment restaurer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  v% = asc("#")+asc("S")*256+asc("E")*256*256+asc("G")*256*256*256
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,mid$(nom$,11,len(nom$))
  FlagModification% = 1
end_sub

sub purger()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, fil$, buf$, aout%, seg$, ns%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  n% = 0
  for i%=1 to count(101)
    nom$ = item_read$(101,i%)
    if instr(nom$,"<supprimé>")=1 then n% = n% + 1
  next i%
  if n%=0
    message "Rien à purger"
    exit_sub
  end_if
  fil$ = file_extract_path$(NomDeTravail$)+"temp_"+file_extract_name$(NomDeTravail$)
  res% = dll_call1("CreateBinaryFile",adr(fil$))
  ' installer l'identifiant
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(fil$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(fil$))
  ' installer le nombre restant de segments
  n% = NombreDeSegments%-n%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(n%),4,9,0)
  aout% = 13  : ' premier octet libre après l'entête
  ns% = 0
  for i%=1 to NombreDeSegments%
    if left$(item_read$(101,i%),1)<>"<"
      ' copier le segment i%
      a% = val(item_read$(1101,i%))  : ' prendre l'adresse de début du segment
      ' installer le marqueur "#SEG"
      s$ = "#SEG"
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(s$))
      ' compter et installer le nouveau numéro du segment
      ns% = ns% + 1
      aout% = aout% + 4   : ' dépasser le marqueur
      res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(ns%),4,aout%,0)
      aout% = aout% + 4   : ' dépasser le numéro de segment
      a% = a% + 8         : ' dépasser le marqueur et la longueur du segment

      ' lire le segment avec son nom et ses données
      n% = val(item_read$(1102,i%))
      buf$ = string$(n%," ")
      res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),n%,a%,adr(buf$))

      ' copier tout ça dans la sortie
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(buf$))
      aout% = aout% + n%   : ' dépasser les données copiées
    end_if
  next i%
  ' fermer tous les fichiers
  res% = dll_call1("CloseBinaryFile",adr(fil$))
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  ' remplacer l'ancien fichier par le nouveau
  file_delete NomDeTravail$
  file_rename fil$,NomDeTravail$
  ' recharger les tables
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
  FlagModification% = 1
end_sub

PS

J'oubliais... prenez bien soin de charger la dernière version V5.83 du 26/01/2016 de KGF.dll...
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Jicehel

avatar

Nombre de messages : 5838
Age : 44
Localisation : 77500
Date d'inscription : 19/04/2011

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Mer 27 Jan 2016 - 16:10

Je ne programme pas du tout pour le moment mais c'est super pour un jeu par exemple qui contient plein de ressources (images etc et si en plus il y avait moyen de le crypter "à chaud" se serait parfait pour rendre les données plus difficilement modifiable.

Par exemple si on stock la fiche de(s) personnage(s) dans une librairie de ce genre, les données serait trop facilement éditables (modifiables), mais ça pourrait s'appliquer à d'autres choses (chapitres d'une aventure dont vous êtes le héros), images, etc ...

C'est peut être déjà possible, je donne juste ma réaction à chaud à la lecture de cette nouveauté.

Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Mer 27 Jan 2016 - 16:17

Merci de ton appréciation, Jicehel.

Les données peuvent être rendues "confidentielles" par cryptage avant la mise en bibliothèque, et décryptés après extraction. Ce sont des fonctions disponibles dans KGF.dll (cryptage propriétaire, par double mot de passe). Le résultat est un fichier binaire qui peut être archivé comme n'importe quel fichier.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Jicehel

avatar

Nombre de messages : 5838
Age : 44
Localisation : 77500
Date d'inscription : 19/04/2011

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Mer 27 Jan 2016 - 18:51

oui tu as raison. C'est à gérer par le programme appelant comme pour toute donnée. La fonction existe donc déjà en effet.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Yannick

avatar

Nombre de messages : 7825
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Dim 31 Jan 2016 - 15:50

Si j' ai bien compris :

Tu fais la "concaténation" de fichiers sous forme de segments binaire en ajoutant un tag de début avec les infos du fichier et un tag de fin.

Question :

Lorsque tu veux supprimer un segment de ton fichier résultat, tu dois faire un fichier (ou copier dans un dlist ) avec les données de 0 à l' octet de fin du fichier précédent, et un fichier (ou copier dans un dlist ) les données placées après ce segment pour ensuite recréer un fichier de remplacement.

la manip n' est elle pas un peu longue en temps si ton fichier devient volumineux ?...
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Dim 31 Jan 2016 - 16:01

Citation :
Tu fais la "concaténation" de fichiers sous forme de segments binaire en ajoutant un tag de début avec les infos du fichier et un tag de fin.
Presque... Il n'y a pas de tag de fin.

Code:
Lorsque tu veux supprimer un segment de ton fichier résultat, tu dois faire un fichier (ou copier dans un dlist ) avec les données de 0 à l' octet de fin du fichier précédent, et un fichier (ou copier dans un dlist ) les données placées après ce segment pour ensuite recréer un fichier de remplacement.
J'aurais pu... mais j'ai choisi un autre procédé. Pour supprimer un segment, je remplace simplement le tag "#SEG" par "#DEL". Ceci signale que le segment est supprimé. Physiquement, il reste toujours dans le fichier, et il y a une opération de restauration qui permet de revenir en arrière, sans perte d'information, sur une telle suppression. Même après une suppression, l'espace occupé par le segment en apparence supprimé reste donc occupé, et il faut une opération de purge pour produire un fichier épuré et compacté. Et cette opération s'effectue à grande vitesse, en copiant, dans l'ordre, les segments non supprimés dans un nouveau fichier, avec une seule opération d'écriture binaire par segment quelque soit sa taille. A la fin, l'ancien fichier sera supprimé et le nouveau renommé vers le nom de l'ancien.

Ainsi, les opérations sons vraiment rapides, et réversibles tant qu'on n'a pas fait l'opération de purge.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Yannick

avatar

Nombre de messages : 7825
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Dim 31 Jan 2016 - 16:15

Ok, j' ai pigé le truc.
Merci de ces précisions Klaus.

En ce moment, j' ai l' esprit occupé par l' archivage sur une clé USB.
Je scanne tous mes documents en *.pdf format qui a de multiples avantages et qui est aussi
le format dans lequel nous pouvons récupérer nos documents administratifs sur le web.
Donc 1 seul format à gérer et lisible à peu près sur toutes les machines par tout le monde.
Mais tout le monde signifie aussi des indésirables... Laughing

Ton mode d' archivage, même sans cryptage, complique déjà la tâche du curieux lambda qui
voudrait lire un document.
Wink
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Dim 31 Jan 2016 - 16:24

Oui, bien vu, Ygeronimi !
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Yannick

avatar

Nombre de messages : 7825
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Dim 31 Jan 2016 - 16:36

Je vais essayer de développer une appli (avec mot de passe et tout ce qui va avec ) en partant de ton principe pour
stocker et visualiser des documents *.pdf le reste ( impression et autres ) étant déjà géré par le visualiseur, celà simplifie
la tâche.

Suite au prochain épisode.... Laughing
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Dim 31 Jan 2016 - 17:47

A tout hasard, voici une version de l'outil de gestion de librairie avec cryptage. Cette option est activée en cochant la ligne "Crypter" dans le menu "Segments". Elle s'applique, tant qu'elle est cochée, sur toutes les opérations "Ajout". Tous ces fichiers seront donc ajoutés en étant cryptés. Pour extraire, supprimer, restaurer ou purger, peu importe l'état de l'option "Crypter" - les segments seront traités selon leur état, décryptés automatiquement lors de l'extraction, et maintenus cryptés sinon. Le programme demandera automatiquement le mot de passe pour le cryptage. Un minimum de 6 caractères est requis, mais on peut faire une phrase complète, ajouter des chiffres, des caractères de ponctuation - plus c'est long et compliqué, mieux c'est.

Mais attention: une fois cryptés, il n'y a aucun moyen de récupérer les segments si l'on a perdu le mot de passe !

Voici cette version:
Code:
' FileLibrary.bas

' Ce programme gère une librarie de fichiers qui a la structure suivante:
'   #KGF
'   FLIB
'   ntot (nombre total de fichiers)
'   seg 1
'   ...
'   seg ntot
' Chaque segment a la structure:
'   #SEG  ou  #DEL
'   nseg
'   lseg (longueur totale du segment sauf les deux premiers mots)
'   snom (longeur du nom)
'   nom (nom en ascii, terminé par un 0)
'   données du segment (de longueur lseg-snom-4)
'
' Opérations:
'   création librairie vide                         ok
'   ouvrir une librairie existante                  ok
'   fermer la librairie en cours                    ok
'   enregistrer la librairie sous un autre nom      ok
'   ajouter un segnement en fin de librarie         ok
'   supprimer d'un segment                          ok
'   localiser le segment numéro n                   ok
'   localiser le segment de nom x                   ok
'   extraire le segment localisé                    ok
'   restaurer un segment supprimé                   ok
'   donner la liste des segments de la librairie    ok
'   purger la liste des segments supprimés          ok
'
' Les opérations se font sur un fichier temporaire.
' L'opération Enregistrer retourne au nom de fichier initial.
'
' La suppression d'un segment se fait en remplaçant simplement
' le marqueur du segment par #DEL. Ainsi, le contenu peut
' être récupéré.
'
' Deux autres marqueurs de segments sont définis:
'   #SEC  - segment crypté
'   #DEC  - segment crypté et supprimé

  constantes()
  variables()
  labels()

  form0()
  menus()
  
  dll()

  invisibles()
  
  initialisations()

  end
  
sortir:
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Sortir quand-même ?")<>1 then return
  end_if
  res% = dll_call1("KillProcessByHandle",handle(0))
  ' fini ici...
  
nouveau:
  nouveau()
  return
  
fermer:
  fermer()
  return
  
ouvrir:
  ouvrir()
  return
  
enregistrer:
  enregistrer()
  return

enregistrersous:
  enregistrersous()
  return
  
ajouter:
  ajouter()
  return
  
supprimer:
  supprimer()
  return
  
restaurer:
  restaurer()
  return
  
extraire:
  extraire()
  return
  
crypter:
  crypter()
  return

purger:
  purger()
  return
  
sub form0()
  caption 0,titre$
  list 101 : full_space 101 : ' width 101,200 : height 101,400
end_sub

sub constantes()
  dim kgf$ : kgf$ = "KGF.dll"
  dim NomDeTravail$ : NomDeTravail$ = dir_current$ + "\KgfFilLib_temp.kfl"
  dim titre$ : titre$ = "Librairie de fichiers"
  data 19,60,103,32,38,20,41,55,86,99,35,34,83,95,80,0
end_sub

sub variables()
  dim res%
  dim NomDeLibrairie$, NomDeSegment$
  dim NombreDeSegments%, SegmentActuel%, AdresseActuelle%, LongueurSegment%
  dim FlagModification%, FlagOpen%, FlagCrypter%
  dim pwd1$, pwd2$
end_sub

sub dll()
  dll_on kgf$
end_sub

sub labels()
  label sortir, nouveau, fermer, ouvrir, enregistrer, enregistrersous
  label ajouter, supprimer, extraire, restaurer, crypter, purger
end_sub

sub menus()
  main_menu 1
  
  sub_menu 2 : parent 2,1 : caption 2,"Fichier"
    sub_menu 21 : parent 21,2 : caption 21,"Nouveau" : on_click 21,nouveau
    sub_menu 22 : parent 22,2 : caption 22,"Ouvrir..." : on_click 22,ouvrir
    sub_menu 23 : parent 23,2 : caption 23,"Fermer" : on_click 23,fermer
    sub_menu 24 : parent 24,2 : caption 24,"Enregistrer" : on_click 24,enregistrer
    sub_menu 25 : parent 25,2 : caption 25,"Enregistrer sous..." : on_click 25,enregistrersous
    sub_menu 26 : parent 26,2 : caption 26,"-"
    sub_menu 27 : parent 27,2 : caption 27,"Sortir" : on_click 27,sortir

  sub_menu 3 : parent 3,1 : caption 3,"Segment"
    sub_menu 31 : parent 31,3 : caption 31,"Ajouter" : on_click 31,ajouter
    sub_menu 32 : parent 32,3 : caption 32,"Supprimer" : on_click 32,supprimer
    sub_menu 33 : parent 33,3 : caption 33,"Extraire" : on_click 33,extraire
    sub_menu 34 : parent 34,3 : caption 34,"Restaurer" : on_click 34,restaurer
    sub_menu 35 : parent 35,3 : caption 35,"-"
    sub_menu 36 : parent 36,3 : caption 36,"Crypter" : on_click 36,crypter
    sub_menu 37 : parent 37,3 : caption 37,"-"
    sub_menu 38 : parent 38,3 : caption 38,"Purger" : on_click 38,purger



end_sub

sub invisibles()
  open_dialog 1000
  save_dialog 1001
  dlist 1101             : ' liste des adresses des segments
  dlist 1102             : ' liste des longueurs des segments
  dlist 1103             : ' liste des adresses des données des segments
  dlist 1104             : ' liste des longueurs des données des segments
  dlist 1105             : ' liste des marques "crypté" pour les segments
end_sub

sub initialisations()
  dim_local i%, c%
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  pwd1$ = ""
  i% = 1
  repeat
   read c%
   if c%<>0 then pwd1$ = pwd1$ + chr$(c%+17)
  until c%=0
end_sub

sub nouveau()
  dim_local buf$, n%
  if FlagModification%=1
    if message_confirmation_yes_no("Une modification est en cours. Créer quand-même ?")<>1 then exit_sub
  end_if
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  res% = dll_call1("CreateBinaryFile",adr(NomDeTravail$))
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(NomDeTravail$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  n% = 0
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,9,0)
  FlagModification% = 1
  NomDeLibrairie$ = ""
  FlagOpen% = 1
  caption 0,"<nouveau> - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
end_sub

sub fermer()
  dim_local nom$
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Enregistrer ?")<>1 then exit_sub
    if NomDeLibrairie$=""
      filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
      nom$ = file_name$(1001)
      if nom$="_" then exit_sub
      if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
      if file_exists(nom$)=1
        if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
      end_if
      NomDeLibrairie$ = nom$
    end_if
    res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
    if file_exists(NomDeLibrairie$)=1 then file_delete NomDeLibrairie$
    file_rename NomDeTravail$,NomDeLibrairie$
    FlagOpen% = 0
    NomDeLibrairie$ = ""
    caption 0,titre$
    FlagModification% = 0
    FlagOpen% = 0
    clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
    NombreDeSegments% = 0
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  NomDeLibrairie$ = ""
  caption 0,titre$
  FlagModification% = 0
  FlagOpen% = 0
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
end_sub

sub ouvrir()
  dim_local nom$, buf$, i%
  if FlagModification%=1
    message "Une modification est en cours. Veuillez fermer le fichier."
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 0
  caption 0,titre$
  filter 1000,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=0
    message "Fichier non trouvé."
    exit_sub
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  buf$ = string$(8," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(nom$),8,1,adr(buf$))
  res% = dll_call1("CloseBinaryFile",adr(nom$))
  if buf$<>"#KGFFLIB"
    message "Pas une librairie valide."
    exit_sub
  end_if
  NomDeLibrairie$ = nom$
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  file_copy NomDeLibrairie$,NomDeTravail$
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 1
  FlagModification% = 0
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
end_sub

sub enregistrer()

end_sub

sub enregistrersous()
  dim_local nom$
  filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  NomDeLibrairie$ = nom$
  FlagOpen% = 1
  FlagModification% = 1
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  file_copy NomDeTravail$,NomDeLibrairie$
end_sub

sub ChercherPremierSegment()
  dim_local n%, a%, nom$, lnom%, prefix$, crypte%
  prefix$ = ""
  res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,9)
  NombreDeSegments% = n%
  SegmentActuel% = 0
  if NombreDeSegments%>0
    SegmentActuel% = 1
    AdresseActuelle% = 13 : ' dépasser les 3 mots d'entête
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL") and (nom$<>"#SEC") and (nom$<>"#DEC")
      message "Librairie invalide - identifiant du premier segment"
      exit_sub
    end_if
    crypte% = 0
    if (nom$="#SEC") or (nom$<>"#DEC") then crypte% = 1
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>1
      message "Librairie invalide - numéro du premier segment"
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if (nom$="#DEL") or (nom$="#DEC") then prefix$ = "<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    item_add 101,prefix$+" "+file_extract_name$(nom$)
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
    item_add 1105,str$(crypte%)
  end_if
end_sub

'   #SEG
'   nseg
'   lseg (longueur totale du segment sauf les deux premiers mots)
'   snom (longeur du nom)
'   nom (nom en ascii, terminé par un 0)
'   données du segment (de longueur lseg-snom-4)
sub ChercherSegmentSuivant()
  dim_local n%, a%, nom$, lnom%, prefix$, crypte%
  prefix$ = ""
  if SegmentActuel%=NombreDeSegments% then exit_sub
  AdresseActuelle% = AdresseActuelle% + 8 + LongueurSegment%
  SegmentActuel% = SegmentActuel% + 1
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL") and (nom$<>"#SEC") and (nom$<>"#DEC")
      message "Librairie invalide - identifiant du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    crypte% = 0
    if (nom$="#SEC") or (nom$<>"#DEC") then crypte% = 1
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>SegmentActuel%
      message "Librairie invalide - numéro du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if (nom$="#DEL") or (nom$="#DEC") then prefix$ ="<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    item_add 101,prefix$+" "+file_extract_name$(nom$)
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
    item_add 1105,str$(crypte%)
end_sub

sub ajouter()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  filter 1000,"Textes |*.txt|Images|*.bmp;*.jpg;*.png|Tous|*.*"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if file_exists(nom$)=0
    message "Fichier introuvable"
    exit_sub
  end_if
  nom1$ = file_extract_name$(nom$)
  if count(101)>0
    for i%=1 to count(101)
      if nom1$=item_read$(101,i%)
        message "Fichier déjà présent dans la librairie"
        exit_sub
      end_if
    next i%
  end_if
  if FlagCrypter%=1
    pwd2$ = message_input$("Mot de passe pour le cryptage","Mot de passe:","")
    if pwd2$="" then exit_sub
    if len(pwd2$)<6
      message "Mot de passe trop court (6 caractères minimum)"
      exit_sub
    end_if
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  siz0% = dll_call1("GetBinaryFileSize",adr(NomDeTravail$))
  siz1% = dll_call1("GetBinaryFileSize",adr(nom$))
  NombreDeSegments% = NombreDeSegments% + 1
  SegmentActuel% = NombreDeSegments%
  ' installer le marqueur "#SEG"
  AdresseActuelle% = siz0% + 1
  item_add 101,nom1$
  item_add 1101,str$(AdresseActuelle%)
  if FlagCrypter%=1
    s$ = "#SEC"
  else
    s$ = "#SEG"
  end_if
' message "Ajout #SEG"
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "c"
  ' installer le numéro du nouveau segment
  a% = AdresseActuelle% + 4
  n% = SegmentActuel%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "d"
  ' installer la longueur du segment
  a% = a% + 4
  n% = 4 + 4 + len(nom1$)+1 + siz1%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
    item_add 1102,str$(n%)
    item_add 1104,str$(siz1%)
        item_add 1105,str$(FlagCrypter%)

' message "e"
  ' installer la longueur du nom
  a% = a% + 4
  n% = len(nom1$) + 1
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "f"
  ' installer le nom du segment
  a% = a% + 4
  s$ = nom1$ + chr$(0)
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "g"
  ' installer les données du segment
  a% = a% + len(nom1$) + 1
  s$ = string$(siz1%," ")
  item_add 1103,str$(a%)
  if FlagCrypter%=1
    res% = dll_call1("CloseBinaryFile",adr(nom$))
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
    res% = dll_call1("OpenBinaryFile",adr(nom$))
  end_if
  res% = dll_call2("ReadBinaryFileToString",adr(nom$),adr(s$))
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "h"
  ' mettre le nombre total de segments à jour
  a% = 9
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(NombreDeSegments%),4,a%,0)
  FlagModification% = 1
' message "i"
  res% = dll_call1("CloseBinaryFile",adr(nom$))
  if FlagCrypter%=1
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
  end_if
end_sub

sub supprimer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment supprimer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  v% = asc("#")+asc("D")*256+asc("E")*256*256+asc("L")*256*256*256
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,"<supprimé>"
  FlagModification% = 1
end_sub

sub extraire()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, buf$, lseg%, aseg%
  dim_local crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment extraire le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  crypte% = val(item_read$(1105,ind%))
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier déjà existant. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  pwd2$ = ""
  if crypte%=1
    pwd2$ = message_input$("Mot de passe pour le décryptage","Mot de passe:","")
    if pwd2$="" then exit_sub
    if len(pwd2$)<6
      message "Mot de passe trop court (6 caractères minimum)"
      exit_sub
    end_if
  end_if
  LongueurSegment% = val(item_read$(1102,ind%))
  aseg% = val(item_read$(1103,ind%))
  lseg% = val(item_read$(1104,ind%))
  buf$ = string$(LongueurSegment%," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lseg%,aseg%,adr(buf$))
  filter 1001,""
  res% = dll_call2("WriteStringToBinaryFile",adr(nom$),adr(buf$))
  if Crypte%=1
    res% = dll_call1("CloseBinaryFile",adr(nom$))
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
    res% = dll_call1("OpenBinaryFile",adr(nom$))
  end_if
end_sub

sub restaurer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  crypte% = val(item_read$(1105,ind%))
  if instr(nom$,"<supprimé>")<>1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment restaurer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  if crypte%=1
    v% = asc("#")+asc("S")*256+asc("E")*256*256+asc("C")*256*256*256
  else
    v% = asc("#")+asc("S")*256+asc("E")*256*256+asc("G")*256*256*256
  end_if
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,mid$(nom$,11,len(nom$))
  FlagModification% = 1
end_sub

sub crypter()
  if FlagCrypter%=1
    FlagCrypter% = 0
    mark_off 36
  else
    FlagCrypter% = 1
    mark_on 36
  end_if
end_sub

sub purger()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, fil$, buf$, aout%, seg$, ns%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  n% = 0
  for i%=1 to count(101)
    nom$ = item_read$(101,i%)
    if instr(nom$,"<supprimé>")=1 then n% = n% + 1
  next i%
  if n%=0
    message "Rien à purger"
    exit_sub
  end_if
  fil$ = file_extract_path$(NomDeTravail$)+"temp_"+file_extract_name$(NomDeTravail$)
  res% = dll_call1("CreateBinaryFile",adr(fil$))
  ' installer l'identifiant
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(fil$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(fil$))
  ' installer le nombre restant de segments
  n% = NombreDeSegments%-n%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(n%),4,9,0)
  aout% = 13  : ' premier octet libre après l'entête
  ns% = 0
  for i%=1 to NombreDeSegments%
    if left$(item_read$(101,i%),1)<>"<"
      ' copier le segment i%
      a% = val(item_read$(1101,i%))  : ' prendre l'adresse de début du segment
      crypte% = val(item_read$(1105,i%))
      ' installer le marqueur "#SEG"
      if crypt%=1
        s$ = "#SEC"
      else
        s$ = "#SEG"
      end_if
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(s$))
      ' compter et installer le nouveau numéro du segment
      ns% = ns% + 1
      aout% = aout% + 4   : ' dépasser le marqueur
      res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(ns%),4,aout%,0)
      aout% = aout% + 4   : ' dépasser le numéro de segment
      a% = a% + 8         : ' dépasser le marqueur et la longueur du segment

      ' lire le segment avec son nom et ses données
      n% = val(item_read$(1102,i%))
      buf$ = string$(n%," ")
      res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),n%,a%,adr(buf$))

      ' copier tout ça dans la sortie
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(buf$))
      aout% = aout% + n%   : ' dépasser les données copiées
    end_if
  next i%
  ' fermer tous les fichiers
  res% = dll_call1("CloseBinaryFile",adr(fil$))
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  ' remplacer l'ancien fichier par le nouveau
  file_delete NomDeTravail$
  file_rename fil$,NomDeTravail$
  ' recharger les tables
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
  FlagModification% = 1
end_sub

EDIT

Pour information:
Le cryptage est effectué par la fonction crypter de KGF.dll. Elle utilise un double mot de passe. Le premier est codé en dur dans le programme, mais sous forme de data cryptés également, afin qu'il ne sois pas visible facilement. Le second doit être saisi pour chaque opération d'ajout en mode crypté, et pour chaque extraction.

Attention:
Le programme n'effectue aucun test sur le mot de passe. et en particulier, lors de l'extraction, le segment visé sera décrypté avec le mote de passe fourni lors du décryptage. Si ce mot de passe est différent du mot de passe utilisé lors du cryptage, il n'y aura aucun message d'erreur, puisque le programme n'a aucun moyen de connaître le bon mot de passe. Simplement, le contenu décrypté sera inutilisable.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Yannick

avatar

Nombre de messages : 7825
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Dim 31 Jan 2016 - 19:06

Merci Klaus.
Je vais voir pour qu' il y ait un "Disclaimer" à l' ouverture de l' application.
un mot de passe sera demandé.
le mot de passe sera stocké dans un fichier param.inf crypté que seul l' appli pourra crypté ou décrypté
Si le mot de pass est correct, l' appli décryptera le ou les fichiers
A la fermeture, l' appli recryptera automatiquement les fichiers

A la création, une adresse mail sera demandé et en cas d' oubli, le mot de passe pourra être envoyé sur cette adresse.
le tout étant que le mail envoyé soit invisible à l' écran scratch

Vois tu mon idée ?.... Laughing
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Dim 31 Jan 2016 - 19:31

Ton idée est bonne. C'est une façon comme une autre de faire - tu seul connais le contexte de ton application. Mais oui, c'est jouable !

Voici une version légèrement corrigée et améliorée. Elle élimine un petit bug et affiche la mention "(crypté)" à côté du nom des fichiers.
Code:
' FileLibrary.bas

' Ce programme gère une librarie de fichiers qui a la structure suivante:
'  #KGF
'  FLIB
'  ntot (nombre total de fichiers)
'  seg 1
'  ...
'  seg ntot
' Chaque segment a la structure:
'  #SEG  ou  #DEL
'  nseg
'  lseg (longueur totale du segment sauf les deux premiers mots)
'  snom (longeur du nom)
'  nom (nom en ascii, terminé par un 0)
'  données du segment (de longueur lseg-snom-4)
'
' Opérations:
'  création librairie vide                        ok
'  ouvrir une librairie existante                  ok
'  fermer la librairie en cours                    ok
'  enregistrer la librairie sous un autre nom      ok
'  ajouter un segnement en fin de librarie        ok
'  supprimer d'un segment                          ok
'  localiser le segment numéro n                  ok
'  localiser le segment de nom x                  ok
'  extraire le segment localisé                    ok
'  restaurer un segment supprimé                  ok
'  donner la liste des segments de la librairie    ok
'  purger la liste des segments supprimés          ok
'
' Les opérations se font sur un fichier temporaire.
' L'opération Enregistrer retourne au nom de fichier initial.
'
' La suppression d'un segment se fait en remplaçant simplement
' le marqueur du segment par #DEL. Ainsi, le contenu peut
' être récupéré.
'
' Deux autres marqueurs de segments sont définis:
'  #SEC  - segment crypté
'  #DEC  - segment crypté et supprimé

  constantes()
  variables()
  labels()

  form0()
  menus()
 
  dll()

  invisibles()
 
  initialisations()

  end
 
sortir:
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Sortir quand-même ?")<>1 then return
  end_if
  res% = dll_call1("KillProcessByHandle",handle(0))
  ' fini ici...
 
nouveau:
  nouveau()
  return
 
fermer:
  fermer()
  return
 
ouvrir:
  ouvrir()
  return
 
enregistrer:
  enregistrer()
  return

enregistrersous:
  enregistrersous()
  return
 
ajouter:
  ajouter()
  return
 
supprimer:
  supprimer()
  return
 
restaurer:
  restaurer()
  return
 
extraire:
  extraire()
  return
 
crypter:
  crypter()
  return

purger:
  purger()
  return
 
sub form0()
  caption 0,titre$
  list 101 : full_space 101 : ' width 101,200 : height 101,400
end_sub

sub constantes()
  dim kgf$ : kgf$ = "KGF.dll"
  dim NomDeTravail$ : NomDeTravail$ = dir_current$ + "\KgfFilLib_temp.kfl"
  dim titre$ : titre$ = "Librairie de fichiers"
  data 19,60,103,32,38,20,41,55,86,99,35,34,83,95,80,0
end_sub

sub variables()
  dim res%
  dim NomDeLibrairie$, NomDeSegment$
  dim NombreDeSegments%, SegmentActuel%, AdresseActuelle%, LongueurSegment%
  dim FlagModification%, FlagOpen%, FlagCrypter%
  dim pwd1$, pwd2$
end_sub

sub dll()
  dll_on kgf$
end_sub

sub labels()
  label sortir, nouveau, fermer, ouvrir, enregistrer, enregistrersous
  label ajouter, supprimer, extraire, restaurer, crypter, purger
end_sub

sub menus()
  main_menu 1
 
  sub_menu 2 : parent 2,1 : caption 2,"Fichier"
    sub_menu 21 : parent 21,2 : caption 21,"Nouveau" : on_click 21,nouveau
    sub_menu 22 : parent 22,2 : caption 22,"Ouvrir..." : on_click 22,ouvrir
    sub_menu 23 : parent 23,2 : caption 23,"Fermer" : on_click 23,fermer
    sub_menu 24 : parent 24,2 : caption 24,"Enregistrer" : on_click 24,enregistrer
    sub_menu 25 : parent 25,2 : caption 25,"Enregistrer sous..." : on_click 25,enregistrersous
    sub_menu 26 : parent 26,2 : caption 26,"-"
    sub_menu 27 : parent 27,2 : caption 27,"Sortir" : on_click 27,sortir

  sub_menu 3 : parent 3,1 : caption 3,"Segment"
    sub_menu 31 : parent 31,3 : caption 31,"Ajouter" : on_click 31,ajouter
    sub_menu 32 : parent 32,3 : caption 32,"Supprimer" : on_click 32,supprimer
    sub_menu 33 : parent 33,3 : caption 33,"Extraire" : on_click 33,extraire
    sub_menu 34 : parent 34,3 : caption 34,"Restaurer" : on_click 34,restaurer
    sub_menu 35 : parent 35,3 : caption 35,"-"
    sub_menu 36 : parent 36,3 : caption 36,"Crypter" : on_click 36,crypter
    sub_menu 37 : parent 37,3 : caption 37,"-"
    sub_menu 38 : parent 38,3 : caption 38,"Purger" : on_click 38,purger



end_sub

sub invisibles()
  open_dialog 1000
  save_dialog 1001
  dlist 1101            : ' liste des adresses des segments
  dlist 1102            : ' liste des longueurs des segments
  dlist 1103            : ' liste des adresses des données des segments
  dlist 1104            : ' liste des longueurs des données des segments
  dlist 1105            : ' liste des marques "crypté" pour les segments
end_sub

sub initialisations()
  dim_local i%, c%
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  pwd1$ = ""
  i% = 1
  repeat
  read c%
  if c%<>0 then pwd1$ = pwd1$ + chr$(c%+17)
  until c%=0
end_sub

sub nouveau()
  dim_local buf$, n%
  if FlagModification%=1
    if message_confirmation_yes_no("Une modification est en cours. Créer quand-même ?")<>1 then exit_sub
  end_if
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  res% = dll_call1("CreateBinaryFile",adr(NomDeTravail$))
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(NomDeTravail$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  n% = 0
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,9,0)
  FlagModification% = 1
  NomDeLibrairie$ = ""
  FlagOpen% = 1
  caption 0,"<nouveau> - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
end_sub

sub fermer()
  dim_local nom$
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Enregistrer ?")<>1 then exit_sub
    if NomDeLibrairie$=""
      filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
      nom$ = file_name$(1001)
      if nom$="_" then exit_sub
      if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
      if file_exists(nom$)=1
        if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
      end_if
      NomDeLibrairie$ = nom$
    end_if
    res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
    if file_exists(NomDeLibrairie$)=1 then file_delete NomDeLibrairie$
    file_rename NomDeTravail$,NomDeLibrairie$
    FlagOpen% = 0
    NomDeLibrairie$ = ""
    caption 0,titre$
    FlagModification% = 0
    FlagOpen% = 0
    clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
    NombreDeSegments% = 0
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  NomDeLibrairie$ = ""
  caption 0,titre$
  FlagModification% = 0
  FlagOpen% = 0
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
end_sub

sub ouvrir()
  dim_local nom$, buf$, i%
  if FlagModification%=1
    message "Une modification est en cours. Veuillez fermer le fichier."
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 0
  caption 0,titre$
  filter 1000,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=0
    message "Fichier non trouvé."
    exit_sub
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  buf$ = string$(8," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(nom$),8,1,adr(buf$))
  res% = dll_call1("CloseBinaryFile",adr(nom$))
  if buf$<>"#KGFFLIB"
    message "Pas une librairie valide."
    exit_sub
  end_if
  NomDeLibrairie$ = nom$
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  file_copy NomDeLibrairie$,NomDeTravail$
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 1
  FlagModification% = 0
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
end_sub

sub enregistrer()

end_sub

sub enregistrersous()
  dim_local nom$
  filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  NomDeLibrairie$ = nom$
  FlagOpen% = 1
  FlagModification% = 1
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  file_copy NomDeTravail$,NomDeLibrairie$
end_sub

sub ChercherPremierSegment()
  dim_local n%, a%, nom$, lnom%, prefix$, crypte%
  prefix$ = ""
  res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,9)
  NombreDeSegments% = n%
  SegmentActuel% = 0
  if NombreDeSegments%>0
    SegmentActuel% = 1
    AdresseActuelle% = 13 : ' dépasser les 3 mots d'entête
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL") and (nom$<>"#SEC") and (nom$<>"#DEC")
      message "Librairie invalide - identifiant du premier segment"
      exit_sub
    end_if
    crypte% = 0
    if (nom$="#SEC") or (nom$="#DEC") then crypte% = 1
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>1
      message "Librairie invalide - numéro du premier segment"
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if (nom$="#DEL") or (nom$="#DEC") then prefix$ = "<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    if crypte%=1
      item_add 101,prefix$+" "+file_extract_name$(nom$)+" (crypté)"
    else
      item_add 101,prefix$+" "+file_extract_name$(nom$)
    end_if
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
    item_add 1105,str$(crypte%)
  end_if
end_sub

'  #SEG
'  nseg
'  lseg (longueur totale du segment sauf les deux premiers mots)
'  snom (longeur du nom)
'  nom (nom en ascii, terminé par un 0)
'  données du segment (de longueur lseg-snom-4)
sub ChercherSegmentSuivant()
  dim_local n%, a%, nom$, lnom%, prefix$, crypte%
  prefix$ = ""
  if SegmentActuel%=NombreDeSegments% then exit_sub
  AdresseActuelle% = AdresseActuelle% + 8 + LongueurSegment%
  SegmentActuel% = SegmentActuel% + 1
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL") and (nom$<>"#SEC") and (nom$<>"#DEC")
      message "Librairie invalide - identifiant du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    crypte% = 0
    if (nom$="#SEC") or (nom$="#DEC") then crypte% = 1
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>SegmentActuel%
      message "Librairie invalide - numéro du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if (nom$="#DEL") or (nom$="#DEC") then prefix$ ="<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    if crypte%=1
      item_add 101,prefix$+" "+file_extract_name$(nom$)+" (crypté)"
    else
      item_add 101,prefix$+" "+file_extract_name$(nom$)
    end_if
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
    item_add 1105,str$(crypte%)
end_sub

sub ajouter()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, nomc$
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  filter 1000,"Textes |*.txt|Images|*.bmp;*.jpg;*.png|Tous|*.*"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if file_exists(nom$)=0
    message "Fichier introuvable"
    exit_sub
  end_if
  nom1$ = file_extract_name$(nom$)
  if count(101)>0
    for i%=1 to count(101)
      nomc$=item_read$(101,i%)
      if right$(nomc$,9)=" (crypté)" then nomc$ = left$(nomc$,len(nomc$) - 9)
      if nom1$=nomc$
        message "Fichier déjà présent dans la librairie"
        exit_sub
      end_if
    next i%
  end_if
  if FlagCrypter%=1
    pwd2$ = message_input$("Mot de passe pour le cryptage","Mot de passe:","")
    if pwd2$="" then exit_sub
    if len(pwd2$)<6
      message "Mot de passe trop court (6 caractères minimum)"
      exit_sub
    end_if
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  siz0% = dll_call1("GetBinaryFileSize",adr(NomDeTravail$))
  siz1% = dll_call1("GetBinaryFileSize",adr(nom$))
  NombreDeSegments% = NombreDeSegments% + 1
  SegmentActuel% = NombreDeSegments%
  ' installer le marqueur "#SEG"
  AdresseActuelle% = siz0% + 1
  if FlagCrypter%=1
    s$ = "#SEC"
    item_add 101,nom1$+" (crypté)"
  else
    s$ = "#SEG"
    item_add 101,nom1$
  end_if
  item_add 1101,str$(AdresseActuelle%)
' message "Ajout #SEG"
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "c"
  ' installer le numéro du nouveau segment
  a% = AdresseActuelle% + 4
  n% = SegmentActuel%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "d"
  ' installer la longueur du segment
  a% = a% + 4
  n% = 4 + 4 + len(nom1$)+1 + siz1%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
    item_add 1102,str$(n%)
    item_add 1104,str$(siz1%)
        item_add 1105,str$(FlagCrypter%)

' message "e"
  ' installer la longueur du nom
  a% = a% + 4
  n% = len(nom1$) + 1
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "f"
  ' installer le nom du segment
  a% = a% + 4
  s$ = nom1$ + chr$(0)
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "g"
  ' installer les données du segment
  a% = a% + len(nom1$) + 1
  s$ = string$(siz1%," ")
  item_add 1103,str$(a%)
  if FlagCrypter%=1
    res% = dll_call1("CloseBinaryFile",adr(nom$))
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
    res% = dll_call1("OpenBinaryFile",adr(nom$))
  end_if
  res% = dll_call2("ReadBinaryFileToString",adr(nom$),adr(s$))
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "h"
  ' mettre le nombre total de segments à jour
  a% = 9
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(NombreDeSegments%),4,a%,0)
  FlagModification% = 1
' message "i"
  res% = dll_call1("CloseBinaryFile",adr(nom$))
  if FlagCrypter%=1
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
  end_if
end_sub

sub supprimer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment supprimer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  crypte% = val(item_read$(1105,ind%))
  if crypte%=1
    v% = asc("#")+asc("D")*256+asc("E")*256*256+asc("C")*256*256*256
  else
    v% = asc("#")+asc("D")*256+asc("E")*256*256+asc("L")*256*256*256
  end_if
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,"<supprimé>"
  FlagModification% = 1
end_sub

sub extraire()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, buf$, lseg%, aseg%
  dim_local crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment extraire le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  crypte% = val(item_read$(1105,ind%))
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier déjà existant. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  pwd2$ = ""
  if crypte%=1
    pwd2$ = message_input$("Mot de passe pour le décryptage","Mot de passe:","")
    if pwd2$="" then exit_sub
    if len(pwd2$)<6
      message "Mot de passe trop court (6 caractères minimum)"
      exit_sub
    end_if
  end_if
  LongueurSegment% = val(item_read$(1102,ind%))
  aseg% = val(item_read$(1103,ind%))
  lseg% = val(item_read$(1104,ind%))
  buf$ = string$(LongueurSegment%," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lseg%,aseg%,adr(buf$))
  filter 1001,""
  res% = dll_call2("WriteStringToBinaryFile",adr(nom$),adr(buf$))
  if Crypte%=1
    res% = dll_call1("CloseBinaryFile",adr(nom$))
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
    res% = dll_call1("OpenBinaryFile",adr(nom$))
  end_if
end_sub

sub restaurer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  crypte% = val(item_read$(1105,ind%))
  if instr(nom$,"<supprimé>")<>1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment restaurer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  if crypte%=1
    v% = asc("#")+asc("S")*256+asc("E")*256*256+asc("C")*256*256*256
  else
    v% = asc("#")+asc("S")*256+asc("E")*256*256+asc("G")*256*256*256
  end_if
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,mid$(nom$,11,len(nom$))
  FlagModification% = 1
end_sub

sub crypter()
  if FlagCrypter%=1
    FlagCrypter% = 0
    mark_off 36
  else
    FlagCrypter% = 1
    mark_on 36
  end_if
end_sub

sub purger()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, fil$, buf$, aout%, seg$, ns%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  n% = 0
  for i%=1 to count(101)
    nom$ = item_read$(101,i%)
    if instr(nom$,"<supprimé>")=1 then n% = n% + 1
  next i%
  if n%=0
    message "Rien à purger"
    exit_sub
  end_if
  fil$ = file_extract_path$(NomDeTravail$)+"temp_"+file_extract_name$(NomDeTravail$)
  res% = dll_call1("CreateBinaryFile",adr(fil$))
  ' installer l'identifiant
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(fil$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(fil$))
  ' installer le nombre restant de segments
  n% = NombreDeSegments%-n%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(n%),4,9,0)
  aout% = 13  : ' premier octet libre après l'entête
  ns% = 0
  for i%=1 to NombreDeSegments%
    if left$(item_read$(101,i%),1)<>"<"
      ' copier le segment i%
      a% = val(item_read$(1101,i%))  : ' prendre l'adresse de début du segment
      crypte% = val(item_read$(1105,i%))
      ' installer le marqueur "#SEG"
      if crypt%=1
        s$ = "#SEC"
      else
        s$ = "#SEG"
      end_if
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(s$))
      ' compter et installer le nouveau numéro du segment
      ns% = ns% + 1
      aout% = aout% + 4  : ' dépasser le marqueur
      res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(ns%),4,aout%,0)
      aout% = aout% + 4  : ' dépasser le numéro de segment
      a% = a% + 8        : ' dépasser le marqueur et la longueur du segment

      ' lire le segment avec son nom et ses données
      n% = val(item_read$(1102,i%))
      buf$ = string$(n%," ")
      res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),n%,a%,adr(buf$))

      ' copier tout ça dans la sortie
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(buf$))
      aout% = aout% + n%  : ' dépasser les données copiées
    end_if
  next i%
  ' fermer tous les fichiers
  res% = dll_call1("CloseBinaryFile",adr(fil$))
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  ' remplacer l'ancien fichier par le nouveau
  file_delete NomDeTravail$
  file_rename fil$,NomDeTravail$
  ' recharger les tables
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
  FlagModification% = 1
end_sub


Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Yannick

avatar

Nombre de messages : 7825
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re    Dim 31 Jan 2016 - 19:59

Il y a un souci avec le cryptage :

il est dit dans la doc :
Citation :
Cette routine applique les deux mots de passe au fichier. Le contenu du fichier sera remplacé par le contenu crypté. Si le fichier était en clair, le résultat de l'opération est un fichier crypté. Si le fichier était crypté, le résultat de l'opération est le fichier d'origine en clair. 
scratch drunken
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Dim 31 Jan 2016 - 20:17

Eh bien, il faut lire la doc, mon vieux ! La fonction crypter travaille sur un fichier, pas sur une chaîne de caractères ! Voici la capture de la doc en ligne:


D'ailleurs, je te déconseille de mettre une chaîne de caractères en clair dans pwd1$. Ceci peut être lu en décodant le source de l'EXE. La variable pwd1$ du programme est déjà préchargée par un mot de passe complexe - tu as juste à fournir pwd2$.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Yannick

avatar

Nombre de messages : 7825
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Dim 31 Jan 2016 - 21:03

Param$ est un fichier *.inf qui contient une ligne qui est le mot de passe
Je le crée 
Je récupère la ligne sans cryptage du fichier qui est : "Admin" (histoire d' être sûr de ce que j' ai dans mon fichier d' origine )
je crypte le fichier
je récupère la ligne du fichier qui n' est plus Admin mais quelques hiéroglyphes ( normal le fichier est crypté )
je repasse mon fichier à la moulinette de la fonction de cryptage ( ce qui devrait me remettre le texte du fichier en clair )
je récupère la ligne du fichier et là je ne retrouve pas "Admin" mais d' autres hiéroglyphes. scratch

En fait la fonction crypte et re-crypte mais ne décrypte pas...


Edit : pour les clés de cryptage, c' est pour l' exemple, je ne me servirai pas de celles là pour l' appli.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Dim 31 Jan 2016 - 21:14

Ok, j'ai survolé ton code trop vite. Autant pour moi.

Essaie avec 0 dans le dernier paramètre. J'ai déjà eu des problèmes avec 1. Je n'ai pas essayé car j'ai la flemme de retaper le code, mais dans le programme de librairie, ça fonctionne comme ça, même avec des fichiers images.

EDIT

Tu as bien sur intérêt à choisir des mots de passe le plus longs possible, avec des lettres en majuscules et en minuscules, des chiffres et pleins de signes spéciaux. Et surtout, éviter des portions communes entre les deux mots de passe !
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Yannick

avatar

Nombre de messages : 7825
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Dim 31 Jan 2016 - 21:30

Cela fonctionne très bien avec 0
Very Happy
le problème apparait avec 1

Edit: 

Bon, aller, c' est l' heure du casse-croute... Laughing
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Dim 31 Jan 2016 - 21:31

Ok. Il faudra que je voie ça un jour ou l'autre. Pour le moment, reste avec 1, comme moi.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Klaus

avatar

Nombre de messages : 9971
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Gestionnaire d'une librairie de fichiers   Lun 1 Fév 2016 - 2:02

Nouvelle version de FileLibrary:
- correction d'une anomalie en affichage du nom de segment après suppression ou restauration
- ajour d'un menu contextuel, activé en cliquant sur une des lignes de la liste des segments

Code:
' FileLibrary.bas

' Ce programme gère une librarie de fichiers qui a la structure suivante:
'   #KGF
'   FLIB
'   ntot (nombre total de fichiers)
'   seg 1
'   ...
'   seg ntot
' Chaque segment a la structure:
'   #SEG  ou  #DEL
'   nseg
'   lseg (longueur totale du segment sauf les deux premiers mots)
'   snom (longeur du nom)
'   nom (nom en ascii, terminé par un 0)
'   données du segment (de longueur lseg-snom-4)
'
' Opérations:
'   création librairie vide                         ok
'   ouvrir une librairie existante                  ok
'   fermer la librairie en cours                    ok
'   enregistrer la librairie sous un autre nom      ok
'   ajouter un segnement en fin de librarie         ok
'   supprimer un segment                            ok
'   localiser le segment numéro n                   ok
'   localiser le segment de nom x                   ok
'   extraire le segment localisé                    ok
'   restaurer un segment supprimé                   ok
'   donner la liste des segments de la librairie    ok
'   purger la liste des segments supprimés          ok
'   crypter optionnellement des segments            ok
'
' Les opérations se font sur un fichier temporaire.
' L'opération Enregistrer retourne au nom de fichier initial.
'
' La suppression d'un segment se fait en remplaçant simplement
' le marqueur du segment par #DEL. Ainsi, le contenu peut
' être récupéré.
'
' Deux autres marqueurs de segments sont définis:
'   #SEC  - segment crypté
'   #DEC  - segment crypté et supprimé

  constantes()
  variables()
  labels()

  form0()
  menus()
  contextmenu()
  
  dll()

  invisibles()
  
  initialisations()

  end
  
sortir:
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Sortir quand-même ?")<>1 then return
  end_if
  res% = dll_call1("KillProcessByHandle",handle(0))
  ' fini ici...
  
nouveau:
  nouveau()
  return
  
fermer:
  fermer()
  return
  
ouvrir:
  ouvrir()
  return
  
enregistrer:
  enregistrer()
  return

enregistrersous:
  enregistrersous()
  return
  
ajouter:
  ajouter()
  return
  
supprimer:
  supprimer()
  close300()
  return
  
restaurer:
  restaurer()
  close300()
  return
  
extraire:
  extraire()
  close300()
  return
  
crypter:
  crypter()
  return

purger:
  purger()
  return
  
context:
  context()
  return
  
close300:
  close300()
  return
  
sub form0()
  caption 0,titre$
  list 101 : full_space 101 : ' width 101,200 : height 101,400
    on_click 101,context
end_sub

sub constantes()
  dim kgf$ : kgf$ = "KGF.dll"
  dim NomDeTravail$ : NomDeTravail$ = dir_current$ + "\KgfFilLib_temp.kfl"
  dim titre$ : titre$ = "Librairie de fichiers"
  data 19,60,103,32,38,20,41,55,86,99,35,34,83,95,80,0
end_sub

sub variables()
  dim res%
  dim NomDeLibrairie$, NomDeSegment$
  dim NombreDeSegments%, SegmentActuel%, AdresseActuelle%, LongueurSegment%
  dim FlagModification%, FlagOpen%, FlagCrypter%
  dim pwd1$, pwd2$
end_sub

sub dll()
  dll_on kgf$
end_sub

sub labels()
  label sortir, nouveau, fermer, ouvrir, enregistrer, enregistrersous
  label ajouter, supprimer, extraire, restaurer, crypter, purger, context
  label close300
end_sub

sub menus()
  main_menu 1
  
  sub_menu 2 : parent 2,1 : caption 2,"Fichier"
    sub_menu 21 : parent 21,2 : caption 21,"Nouveau" : on_click 21,nouveau
    sub_menu 22 : parent 22,2 : caption 22,"Ouvrir..." : on_click 22,ouvrir
    sub_menu 23 : parent 23,2 : caption 23,"Fermer" : on_click 23,fermer
    sub_menu 24 : parent 24,2 : caption 24,"Enregistrer" : on_click 24,enregistrer
    sub_menu 25 : parent 25,2 : caption 25,"Enregistrer sous..." : on_click 25,enregistrersous
    sub_menu 26 : parent 26,2 : caption 26,"-"
    sub_menu 27 : parent 27,2 : caption 27,"Sortir" : on_click 27,sortir

  sub_menu 3 : parent 3,1 : caption 3,"Segment"
    sub_menu 31 : parent 31,3 : caption 31,"Ajouter" : on_click 31,ajouter
    sub_menu 32 : parent 32,3 : caption 32,"Supprimer" : on_click 32,supprimer
    sub_menu 33 : parent 33,3 : caption 33,"Extraire" : on_click 33,extraire
    sub_menu 34 : parent 34,3 : caption 34,"Restaurer" : on_click 34,restaurer
    sub_menu 35 : parent 35,3 : caption 35,"-"
    sub_menu 36 : parent 36,3 : caption 36,"Crypter" : on_click 36,crypter
    sub_menu 37 : parent 37,3 : caption 37,"-"
    sub_menu 38 : parent 38,3 : caption 38,"Purger" : on_click 38,purger
end_sub

sub contextmenu()
  form 300 : hide 300 : command_target_is 300 : on_close 300,close300
    caption 300,"Menu contextuel" : border_small 300 : width 300,170 : height 300,120
  alpha 301 : left 301,10 : top 301,10 : caption 301,"Supprimer" : on_click 301,supprimer
  alpha 302 : left 302,10 : top 302,30 : caption 302,"Extraire" : on_click 302,extraire
  alpha 303 : left 303,10 : top 303,50 : caption 303,"Restaurer" : on_click 303,restaurer
  command_target_is 0
end_sub

sub invisibles()
  open_dialog 1000
  save_dialog 1001
  dlist 1101             : ' liste des adresses des segments
  dlist 1102             : ' liste des longueurs des segments
  dlist 1103             : ' liste des adresses des données des segments
  dlist 1104             : ' liste des longueurs des données des segments
  dlist 1105             : ' liste des marques "crypté" pour les segments
end_sub

sub initialisations()
  dim_local i%, c%
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  pwd1$ = ""
  i% = 1
  repeat
   read c%
   if c%<>0 then pwd1$ = pwd1$ + chr$(c%+17)
  until c%=0
end_sub

sub nouveau()
  dim_local buf$, n%
  if FlagModification%=1
    if message_confirmation_yes_no("Une modification est en cours. Créer quand-même ?")<>1 then exit_sub
  end_if
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  res% = dll_call1("CreateBinaryFile",adr(NomDeTravail$))
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(NomDeTravail$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  n% = 0
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,9,0)
  FlagModification% = 1
  NomDeLibrairie$ = ""
  FlagOpen% = 1
  caption 0,"<nouveau> - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
end_sub

sub fermer()
  dim_local nom$
  if FlagModification%=1
    if message_confirmation_yes_no("Modification en cours. Enregistrer ?")<>1 then exit_sub
    if NomDeLibrairie$=""
      filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
      nom$ = file_name$(1001)
      if nom$="_" then exit_sub
      if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
      if file_exists(nom$)=1
        if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
      end_if
      NomDeLibrairie$ = nom$
    end_if
    res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
    if file_exists(NomDeLibrairie$)=1 then file_delete NomDeLibrairie$
    file_rename NomDeTravail$,NomDeLibrairie$
    FlagOpen% = 0
    NomDeLibrairie$ = ""
    caption 0,titre$
    FlagModification% = 0
    FlagOpen% = 0
    clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
    NombreDeSegments% = 0
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  NomDeLibrairie$ = ""
  caption 0,titre$
  FlagModification% = 0
  FlagOpen% = 0
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
end_sub

sub ouvrir()
  dim_local nom$, buf$, i%
  if FlagModification%=1
    message "Une modification est en cours. Veuillez fermer le fichier."
    exit_sub
  end_if
  if FlagOpen%=1 then res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 0
  caption 0,titre$
  filter 1000,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=0
    message "Fichier non trouvé."
    exit_sub
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  buf$ = string$(8," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(nom$),8,1,adr(buf$))
  res% = dll_call1("CloseBinaryFile",adr(nom$))
  if buf$<>"#KGFFLIB"
    message "Pas une librairie valide."
    exit_sub
  end_if
  NomDeLibrairie$ = nom$
  if file_exists(NomDeTravail$)=1 then file_delete NomDeTravail$
  file_copy NomDeLibrairie$,NomDeTravail$
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  FlagOpen% = 1
  FlagModification% = 0
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104 : clear 1105
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
end_sub

sub enregistrer()

end_sub

sub enregistrersous()
  dim_local nom$
  filter 1001,"Librairie de fichiers (*.kfl)|*.kfl"
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if lower$(right$(nom$,4))<>".kfl" then nom$ = nom$ + ".kfl"
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier existe déjà. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  NomDeLibrairie$ = nom$
  FlagOpen% = 1
  FlagModification% = 1
  caption 0,file_extract_name$(NomDeLibrairie$)+" - "+titre$
  file_copy NomDeTravail$,NomDeLibrairie$
end_sub

sub ChercherPremierSegment()
  dim_local n%, a%, nom$, lnom%, prefix$, crypte%
  prefix$ = ""
  res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,9)
  NombreDeSegments% = n%
  SegmentActuel% = 0
  if NombreDeSegments%>0
    SegmentActuel% = 1
    AdresseActuelle% = 13 : ' dépasser les 3 mots d'entête
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL") and (nom$<>"#SEC") and (nom$<>"#DEC")
      message "Librairie invalide - identifiant du premier segment"
      exit_sub
    end_if
    crypte% = 0
    if (nom$="#SEC") or (nom$="#DEC") then crypte% = 1
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>1
      message "Librairie invalide - numéro du premier segment"
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if (nom$="#DEL") or (nom$="#DEC") then prefix$ = "<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    if crypte%=1
      item_add 101,prefix$+" "+file_extract_name$(nom$)+" (crypté)"
    else
      item_add 101,prefix$+" "+file_extract_name$(nom$)
    end_if
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
    item_add 1105,str$(crypte%)
  end_if
end_sub

'   #SEG
'   nseg
'   lseg (longueur totale du segment sauf les deux premiers mots)
'   snom (longeur du nom)
'   nom (nom en ascii, terminé par un 0)
'   données du segment (de longueur lseg-snom-4)
sub ChercherSegmentSuivant()
  dim_local n%, a%, nom$, lnom%, prefix$, crypte%
  prefix$ = ""
  if SegmentActuel%=NombreDeSegments% then exit_sub
  AdresseActuelle% = AdresseActuelle% + 8 + LongueurSegment%
  SegmentActuel% = SegmentActuel% + 1
    a% = AdresseActuelle%
    nom$ = "abcd"
    ' lire le marqueur "#SEG"
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),4,a%,adr(nom$))
    if (nom$<>"#SEG") and (nom$<>"#DEL") and (nom$<>"#SEC") and (nom$<>"#DEC")
      message "Librairie invalide - identifiant du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    crypte% = 0
    if (nom$="#SEC") or (nom$="#DEC") then crypte% = 1
    a% = a% + 4
    ' lire le numéro du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(n%),4,a%)
    if n%<>SegmentActuel%
      message "Librairie invalide - numéro du segment "+str$(SegmentActuel%)
      exit_sub
    end_if
    a% = a% + 4
    ' prendre la longueur du segment
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(LongueurSegment%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du segment
    if (nom$="#DEL") or (nom$="#DEC") then prefix$ ="<supprimé>"
    ' prendre la longueur du nom
    res% = dll_call4("ReadBlockFromBinaryFile",adr(NomDeTravail$),adr(lnom%),4,a%)
    a% = a% + 4    : ' dépasser la longueur du nom
    nom$ = string$(lnom%-1," ")
    res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lnom%-1,a%,adr(nom$))
    if crypte%=1
      item_add 101,prefix$+" "+file_extract_name$(nom$)+" (crypté)"
    else
      item_add 101,prefix$+" "+file_extract_name$(nom$)
    end_if
    item_add 1101,str$(AdresseActuelle%)
    item_add 1102,str$(LongueurSegment%)
    item_add 1103,str$(a%+lnom%)
    item_add 1104,str$(LongueurSegment%-lnom%-4-4-1)
    item_add 1105,str$(crypte%)
end_sub

sub ajouter()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, nomc$
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  filter 1000,"Textes |*.txt|Images|*.bmp;*.jpg;*.png|Tous|*.*"
  nom$ = file_name$(1000)
  if nom$="_" then exit_sub
  if file_exists(nom$)=0
    message "Fichier introuvable"
    exit_sub
  end_if
  nom1$ = file_extract_name$(nom$)
  if count(101)>0
    for i%=1 to count(101)
      nomc$=item_read$(101,i%)
      if right$(nomc$,9)=" (crypté)" then nomc$ = left$(nomc$,len(nomc$) - 9)
      if nom1$=nomc$
        message "Fichier déjà présent dans la librairie"
        exit_sub
      end_if
    next i%
  end_if
  if FlagCrypter%=1
    pwd2$ = message_input$("Mot de passe pour le cryptage","Mot de passe:","")
    if pwd2$="" then exit_sub
    if len(pwd2$)<6
      message "Mot de passe trop court (6 caractères minimum)"
      exit_sub
    end_if
  end_if
  res% = dll_call1("OpenBinaryFile",adr(nom$))
  siz0% = dll_call1("GetBinaryFileSize",adr(NomDeTravail$))
  siz1% = dll_call1("GetBinaryFileSize",adr(nom$))
  NombreDeSegments% = NombreDeSegments% + 1
  SegmentActuel% = NombreDeSegments%
  ' installer le marqueur "#SEG"
  AdresseActuelle% = siz0% + 1
  if FlagCrypter%=1
    s$ = "#SEC"
    item_add 101,nom1$+" (crypté)"
  else
    s$ = "#SEG"
    item_add 101,nom1$
  end_if
  item_add 1101,str$(AdresseActuelle%)
' message "Ajout #SEG"
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "c"
  ' installer le numéro du nouveau segment
  a% = AdresseActuelle% + 4
  n% = SegmentActuel%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "d"
  ' installer la longueur du segment
  a% = a% + 4
  n% = 4 + 4 + len(nom1$)+1 + siz1%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
    item_add 1102,str$(n%)
    item_add 1104,str$(siz1%)
        item_add 1105,str$(FlagCrypter%)

' message "e"
  ' installer la longueur du nom
  a% = a% + 4
  n% = len(nom1$) + 1
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(n%),4,a%,0)
' message "f"
  ' installer le nom du segment
  a% = a% + 4
  s$ = nom1$ + chr$(0)
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "g"
  ' installer les données du segment
  a% = a% + len(nom1$) + 1
  s$ = string$(siz1%," ")
  item_add 1103,str$(a%)
  if FlagCrypter%=1
    res% = dll_call1("CloseBinaryFile",adr(nom$))
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
    res% = dll_call1("OpenBinaryFile",adr(nom$))
  end_if
  res% = dll_call2("ReadBinaryFileToString",adr(nom$),adr(s$))
  res% = dll_call2("AppendStringToBinaryFile",adr(NomDeTravail$),adr(s$))
' message "h"
  ' mettre le nombre total de segments à jour
  a% = 9
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(NombreDeSegments%),4,a%,0)
  FlagModification% = 1
' message "i"
  res% = dll_call1("CloseBinaryFile",adr(nom$))
  if FlagCrypter%=1
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
  end_if
end_sub

sub supprimer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment supprimer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  crypte% = val(item_read$(1105,ind%))
  if crypte%=1
    v% = asc("#")+asc("D")*256+asc("E")*256*256+asc("C")*256*256*256
  else
    v% = asc("#")+asc("D")*256+asc("E")*256*256+asc("L")*256*256*256
  end_if
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,"<supprimé> "+nom$
  FlagModification% = 1
end_sub

sub extraire()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, buf$, lseg%, aseg%
  dim_local crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  if instr(nom$,"<supprimé>")=1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment extraire le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  crypte% = val(item_read$(1105,ind%))
  nom$ = file_name$(1001)
  if nom$="_" then exit_sub
  if file_exists(nom$)=1
    if message_confirmation_yes_no("Fichier déjà existant. Remplacer ?")<>1 then exit_sub
    file_delete nom$
  end_if
  pwd2$ = ""
  if crypte%=1
    pwd2$ = message_input$("Mot de passe pour le décryptage","Mot de passe:","")
    if pwd2$="" then exit_sub
    if len(pwd2$)<6
      message "Mot de passe trop court (6 caractères minimum)"
      exit_sub
    end_if
  end_if
  LongueurSegment% = val(item_read$(1102,ind%))
  aseg% = val(item_read$(1103,ind%))
  lseg% = val(item_read$(1104,ind%))
  buf$ = string$(LongueurSegment%," ")
  res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),lseg%,aseg%,adr(buf$))
  filter 1001,""
  res% = dll_call2("WriteStringToBinaryFile",adr(nom$),adr(buf$))
  if Crypte%=1
    res% = dll_call1("CloseBinaryFile",adr(nom$))
    res% = dll_call4("crypter",adr(pwd1$),adr(pwd2$),adr(nom$),0)
    res% = dll_call1("OpenBinaryFile",adr(nom$))
  end_if
end_sub

sub restaurer()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  ind% = item_index(101)
  if ind%<1 then exit_sub
  nom$ = item_read$(101,ind%)
  crypte% = val(item_read$(1105,ind%))
  if instr(nom$,"<supprimé>")<>1 then exit_sub
  if message_confirmation_yes_no("Voulez-vous vraiment restaurer le segment:"+chr$(13)+chr$(10)+nom$)<>1 then exit_sub
  SegmentActuel% = ind%
  AdresseActuelle% = val(item_read$(1101,ind%))
  if crypte%=1
    v% = asc("#")+asc("S")*256+asc("E")*256*256+asc("C")*256*256*256
  else
    v% = asc("#")+asc("S")*256+asc("E")*256*256+asc("G")*256*256*256
  end_if
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(NomDeTravail$),adr(v%),4,AdresseActuelle%,0)
  item_delete 101,ind%
  item_insert 101,ind%,mid$(nom$,12,len(nom$))
  FlagModification% = 1
end_sub

sub crypter()
  if FlagCrypter%=1
    FlagCrypter% = 0
    mark_off 36
  else
    FlagCrypter% = 1
    mark_on 36
  end_if
end_sub

sub purger()
  dim_local nom$, nom1$, i%,siz0%, siz1%, s$, n%, a%, ind%, v%, fil$, buf$, aout%, seg$, ns%, crypte%
  if FlagOpen%=0
    message "Aucune librairie ouverte"
    exit_sub
  end_if
  if NombreDeSegments%=0 then exit_sub
  n% = 0
  for i%=1 to count(101)
    nom$ = item_read$(101,i%)
    if instr(nom$,"<supprimé>")=1 then n% = n% + 1
  next i%
  if n%=0
    message "Rien à purger"
    exit_sub
  end_if
  fil$ = file_extract_path$(NomDeTravail$)+"temp_"+file_extract_name$(NomDeTravail$)
  res% = dll_call1("CreateBinaryFile",adr(fil$))
  ' installer l'identifiant
  buf$ = "#KGFFLIB"
  res% = dll_call2("WriteStringToBinaryFile",adr(fil$),adr(buf$))
  res% = dll_call1("OpenBinaryFile",adr(fil$))
  ' installer le nombre restant de segments
  n% = NombreDeSegments%-n%
  res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(n%),4,9,0)
  aout% = 13  : ' premier octet libre après l'entête
  ns% = 0
  for i%=1 to NombreDeSegments%
    if left$(item_read$(101,i%),1)<>"<"
      ' copier le segment i%
      a% = val(item_read$(1101,i%))  : ' prendre l'adresse de début du segment
      crypte% = val(item_read$(1105,i%))
      ' installer le marqueur "#SEG"
      if crypt%=1
        s$ = "#SEC"
      else
        s$ = "#SEG"
      end_if
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(s$))
      ' compter et installer le nouveau numéro du segment
      ns% = ns% + 1
      aout% = aout% + 4   : ' dépasser le marqueur
      res% = dll_call5("ReplaceBlockInBinaryFile",adr(fil$),adr(ns%),4,aout%,0)
      aout% = aout% + 4   : ' dépasser le numéro de segment
      a% = a% + 8         : ' dépasser le marqueur et la longueur du segment

      ' lire le segment avec son nom et ses données
      n% = val(item_read$(1102,i%))
      buf$ = string$(n%," ")
      res% = dll_call4("ReadBlockFromBinaryFileToString",adr(NomDeTravail$),n%,a%,adr(buf$))

      ' copier tout ça dans la sortie
      res% = dll_call2("AppendStringToBinaryFile",adr(fil$),adr(buf$))
      aout% = aout% + n%   : ' dépasser les données copiées
    end_if
  next i%
  ' fermer tous les fichiers
  res% = dll_call1("CloseBinaryFile",adr(fil$))
  res% = dll_call1("CloseBinaryFile",adr(NomDeTravail$))
  ' remplacer l'ancien fichier par le nouveau
  file_delete NomDeTravail$
  file_rename fil$,NomDeTravail$
  ' recharger les tables
  res% = dll_call1("OpenBinaryFile",adr(NomDeTravail$))
  clear 101 : clear 1101 : clear 1102 : clear 1103 : clear 1104
  NombreDeSegments% = 0
  ' ici, charger la liste des segments !
  ChercherPremierSegment()
  if NombreDeSegments%>1
    for i%=2 to NombreDeSegments%
      ChercherSegmentSuivant()
    next i%
  end_if
  FlagModification% = 1
end_sub

sub context()
  if count(101)=0 then exit_sub
  dim_local caretx%,carety%,selstart%,selend%,line%,col%,x%,y%,w%,h%
  res% = dll_call6("GetCaretAndCoordinates",adr(caretx%),adr(carety%),adr(selstart%),adr(selend%),adr(line%),adr(col%))
  res% = dll_call5("GetFormClientMetrics",handle(101),adr(x%),adr(y%),adr(w%),adr(h%))
  caretx% = mouse_x_left_down(101) : carety% = mouse_y_left_down(101)
  inactive 0
  top 300,carety%+y%+5 : left 300,caretx%+x%+5 : show 300
end_sub

sub close300()
  hide 300
  active 0 : to_foreground 0 : set_focus 101
end_sub

Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
Contenu sponsorisé




MessageSujet: Re: Gestionnaire d'une librairie de fichiers   

Revenir en haut Aller en bas
 
Gestionnaire d'une librairie de fichiers
Voir le sujet précédent Voir le sujet suivant Revenir en haut 
Page 1 sur 1
 Sujets similaires
-
» [fermé]Points d'exclamation jaune dans gestionnaire de prérihpériques
» Gestion hasardeuse des fichiers gpx
» Hébergement gratuit images photos fichiers
» support du format svg en librairie
» Comodo Cleaning Essentials, l'essentiel pour supprimer les indésirables

Permission de ce forum:Vous ne pouvez pas répondre aux sujets dans ce forum
FORUM DE DISCUSSION SUR LE LANGAGE PANORAMIC :: PANORAMIC 32 bits :: Vos sources, vos utilitaires à partager-
Sauter vers: