Exporter Excel encrypté

Byfranck · 22 Juillet 2009

Bonjour à tous,

J'ai une base de données de laquelle je souhaite que les utilisateurs puissent exporter les lignes qui ont été modifiées (Ils ont accès à la base au travers d'Usf qui leurs servent d'interfaces).
Grâce au coup de mais que l'on ma donné, j'exporte maintenant les lignes modifiées dans un classeur Excel.
Je voudrais pouvoir "cryter" les données contenues dans toutes les cellules <>""
J'ai trouvé une fonction Cryptage/decryptage qui serait amplement suffisante pour mon apli. (développée semble-t-il par "AV" .. merci à lui 🙂 ):
https://www.excel-downloads.com/threads/crypter-les-numes-de-candidats.60638/

Mon problème est que j'extrais les lignes modifiées dans une feuille temporaire et je voudrait donc crypter les cellules non vides (pour ne pas avoir de 0) et que je ne sais pas comment m'y prendre.
J'ai penser créer une feuille spécifique dans laquelle j'exporterais et crypterais une par une les cellule non vides:

Code:

    With Sheets("Extraction")
        DerLig = .Range("A" & Rows.Count).End(xlUp).Row
    For Lig = 2 To DerLig
      On Error Resume Next
      If .Range("A1:AD65000").Cells.Value <> "" Then
'???????????????
      End If
      On Error GoTo 0

là ou j'ai mis des point ?? c'est làou il faudrait demander de copier en cryptant sur la feuille Extraction2

Quelqu'un pourrait me guider ?

Cordialement

PMO2 · 23 Juillet 2009

Re : Exporter Excel encrypté

Bonjour,

Une solution avec le code ci-dessous. J'y ai recopié les fonctions de AV puisqu'elles fonctionnent très bien.
En revanche, j'ai développé la Sub Cryptage_Decryptage qui permet de crypter ou décrypter tout le contenu d'une feuille d'un seul coup.
Cette Sub est ambivalente car soit elle crypte, soit elle décrypte grâce à l'usage d'une chaîne de reconnaissance (CHAR_RECONNAISSANCE).
Si la feuille ne contient aucune donnée commençant par cette chaîne de reconnaissance alors il s'agit d'une feuille non cryptée et on la crypte.
Dans le cas contraire, il s'agit d'une feuille cryptée et on la décrypte.

MARCHE A SUIVRE
1) copiez le code suivant dans un module standard

Code:

'///////////////////////////////////////////////////////////////////
'/// Les fonctions CRYPTE et DECRYPTE ont été développées par AV ///
Function CRYPTE(Chaine$) As Variant
Dim x$
Dim i&
For i = 1 To Len(Chaine)
  x = x & Format(Asc(Mid(Chaine, i, 1)), "000") & "08"
Next
CRYPTE = x
End Function
Function DECRYPTE(Chaine$) As Variant
Dim x$
Dim i&
For i = 1 To Len(Chaine) Step 5
  x = x & Chr(Mid(Chaine, i, 3))
Next
DECRYPTE = x
End Function
'///////////////////////////////////////////////////////////////////

Sub Cryptage_Decryptage()
Dim CHAR_RECONNAISSANCE As String
Dim S As Worksheet
Dim R As Range
Dim var
Dim A$
Dim Col&
Dim Lig&
Dim i&
Dim j&
Dim Decryptage As Boolean
Dim bool As Boolean
CHAR_RECONNAISSANCE = Chr(159) & Chr(131) & Chr(138) '= ŸƒŠ
Set S = ActiveSheet
'--- Si il existe un donnée en IV65536, on sort ---
If Not IsEmpty(S.Range("iv65536")) Then
  [iv65536].Select
  MsgBox prompt:="Une donnée existe dans la cellule ''IV65536''.", _
    Buttons:=vbOKOnly + vbCritical, Title:="Programme stoppé (trop long à exécuter)"
  Exit Sub
End If
'--- Recherche de la dernière ligne et de la dernière colonne de la plage ---
For i& = xlByRows To xlByColumns
  Set R = S.Cells.Find(what:="*", after:=[iv65536], SearchOrder:=i&, SearchDirection:=xlPrevious)
  If Not R Is Nothing Then
    A$ = R.Address
    Do
      Set R = S.Cells.FindNext(R)
    Loop While Not R Is Nothing And R.Address <> A$
    If i& = xlByRows Then Lig& = R.Row
    If i& = xlByColumns Then Col& = R.Column
  End If
Next i&
'--- On sort si la feuille est vide ---
If Lig& = 0 Then
  MsgBox "La feuille ''" & S.Name & "'' est vide."
  Exit Sub
End If
'--- Est-ce déjà encrypté ? ---
Set R = S.Range(S.Cells(1, 1), S.Cells(Lig&, Col&))
var = R.Formula
For i& = 1 To Lig&
  For j& = 1 To Col&
    If Left(CStr(var(i&, j&)), Len(CHAR_RECONNAISSANCE)) = CHAR_RECONNAISSANCE Then
      Decryptage = True
      bool = True
      Exit For
    End If
    If bool Then Exit For
  Next j&
Next i&
'--- Mise en tableau des données ---
For i& = 1 To Lig&
  For j& = 1 To Col&
    If Not IsEmpty(var(i&, j&)) And var(i&, j&) <> "" Then
      If Decryptage Then
        var(i&, j&) = CStr(DECRYPTE(CStr(Mid(var(i&, j&), Len(CHAR_RECONNAISSANCE) + 1))))
      Else
        var(i&, j&) = CHAR_RECONNAISSANCE & CStr(CRYPTE(CStr(var(i&, j&))))
      End If
    End If
  Next j&
Next i&
'--- Inscription dans une nouvelle feuille ---
Set S = Sheets.Add
    '°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
    '°°° Ne pas utiliser la montée du tableau dans un Range en   °°°
    '°°° un seul coup, à cause de l'erreur 1004 pouvant survenir °°°
    '°°°        (limite de caractères à 912 par exemple).        °°°
    '°°°        Enumérer, plutôt, chaque item du tableau.        °°°
    '°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
For i& = 1 To Lig&
  For j& = 1 To Col&
    S.Range(S.Cells(i&, j&), S.Cells(i&, j&)) = var(i&, j&)
  Next j&
Next i&
End Sub

2) activez une feuille contenant les données à crypter et lancez la macro Cryptage_Decryptage. Le résultat s'affiche dans une nouvelle feuille.
3) pour décrypter, activez une feuille cryptée et lancez la macro Cryptage_Decryptage. Le résultat s'affiche dans une nouvelle feuille.

Cordialement.

PMO
Patrick Morange

Byfranck · 24 Juillet 2009

Re : Exporter Excel encrypté

Bonjour Patrick,
Merci pour tes lumières, je vais essayer d'appliquer ton code dans ma base.
Malheureusement une fois chargé je n'arrive pas à décompresser le fichier que tu as joints (j'ai essyé aussi avec 7Zip et j'obtiens un fichier sans extension: si je lui colle un .xls Excel ne le reconnait pas ...)
Heureusement il y a le code dans ton message je vais essayer de m'en sortir.

Cordialement
Franck

Byfranck · 24 Juillet 2009

Re : Exporter Excel encrypté

Re_Bonjour,

Je ne m'en sort pas trop mal avec un copier coller des codes mais quelques problèmes subsistent:
avec la fonction crypte et decrypte du fichier original de AV les dates sont cryptées et parfaitement restiueés au format date, avec tes modifs je perd le format (ça devient du standart), ça pour moi c'est un big problème, j'ai besoin de garder les formats originaux de mes cellulles (dd/mm/yyyy hh:mm) sinoin ensuite j'ai des pb dans les textbox des UsF et pour mes calculs.
J'ai pensé que cela venait de la reconnaissance des cellules cryptées, j'ai essayé de supprimer les lignes de code qui ajoutent les ŸƒŠ mais tout ce que j'essai fait planter la macro.
Idem dans mon tableau j'ai 250 colonnes et les colonne AE, AF IJ, IK et IM sont des colonnes de calcul, n'y aurait-il pas moyen de ne pas traiter ces colonne de façon à ne pas "casser" les formules?

l'autre point est que pour éviter tout risque, je voudrais qu'une fois codé, le nom de l'onglet soit toujours le même (Extraction)

Si tu pouvais m'aider.. je viens de passer un bon moment la-dessus et je n'y arrive pas!

Je ne sais pas si tu auras le temps de m'aider ...
En tout cas si c'est possible merci d'avance

Cordialement
Franck

PMO2 · 24 Juillet 2009

Re : Exporter Excel encrypté

Bonjour,

Pour pouvoir avancer, il me faudrait votre classeur édulcoré (par exemple ne laisser que 3 lignes) mais en conserver la structure (mise en page, formules, etc).
Si vous pouvez l'envoyer, je verrai ce que je peut faire en situation.

Cordialement.

PMO
Patrick Morange

Byfranck · 24 Juillet 2009

Re : Exporter Excel encrypté

Bonsoir,
J'ai fais ce que je pouvais pour laisser le miimum.
En fait je voudrais exporter tel que cela fonctionne avec le module actuel, mais que le fichier exporté soit cryté en gardant les formats date, département et les formules.
Le plus simple est probablement de ne pas crypter ces colonnes ce n'est pas si grave.

Attention si tu fais des essais, la cellule IQ 4 enregistre la date et l'heure de la dernière extraction, a l'extraction suivante si tu ne mets pas une date antérieurs aux dates de modif des lignes dans la colonne IQ rien ne va s'extraire.

Dans le tableau joint il y a une référence circulaire ... je ne sais pas pourquoi mais ça ne semble pas perturber la macro d'extraction.

J'ai malgré tout été obligé de Zipper ...
J'espère si tu m'envoi une réponse que je pourai dé-zipper

Cordialement @+

PMO2 · 25 Juillet 2009

Re : Exporter Excel encrypté

Bonjour,

1) J'ai modifié les formules de la colonne AF en y incluant directement la fonction AUJOURDHUI() plutôt que de faire référence à une cellule contenant cette fonction. Cela évite, dans la feuille "Extraction", d'avoir une référence inexistante. MAIS est-ce cela qu'il fallait faire ???
=SI(AG8="";"?";SI(AG8-AUJOURDHUI()>0;AG8-AUJOURDHUI();"RETARD"))

2) J'ai modifié le code (faites une recherche sur la chaîne /// modif pmo /// pour situer les modifications) et j'ai inclus le module de cryptage/décryptage.
Ainsi, lorsque vous lancez votre macro "Extraction" elle appelle directement la macro "Cryptage_Decryptage" pour obtenir un nouveau classeur avec la feuille "Extraction" cryptée.

3) Pour le décryptage, ouvrir le nouveau classeur et activer sa feuille "Extraction" puis lancer la macro "Cryptage_Decryptage"

4) Comme vous avez copié/collé les lignes avec Copy Destination:= tous les formats sont conservés. Du moins, c'est ce que je constate chez moi.

Codes à copier

Code:

Sub Extraction()
  Dim DerLig As Long, DerLigD As Long, Lig As Long
  Dim FlagCréée As Boolean
  Dim VDateEnvoi As Date, VDateLig As Date
  Dim VPathFic As String
  
  ' Initialisation des variables
  FlagCréée = False
  ' Avec ce classeur et la feuille 1
  With ThisWorkbook.Sheets("Feuil1")
    ' Récupérer la dernière date d'envoi
    VDateEnvoi = .Range("IQ4").Value
    ' Récupérer la dernière ligne du tableau
    DerLig = .Range("A" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne de la 8 à la dernière
    For Lig = 8 To DerLig
      'VDateLig = .Range("IQ" & Lig)
      On Error Resume Next
      VDateLig = .Range("IQ" & Lig)
      ' Si pas de date de modif, mettre une date bidon de début du siècle
      If Err.Number <> 0 Then
        VDateLig = "01/01/1900"
      End If
      On Error GoTo 0
      ' Si la date de la ligne est supérieur à la date du dernier envoi
      ' On procède à la copie de la ligne
      If VDateLig > VDateEnvoi Then
        ' La première fois, créer un feuille Extraction
        If FlagCréée = False Then
          FlagCréée = True
          Sheets.Add after:=Sheets(Sheets.Count)
          ActiveSheet.Name = "Extraction"
          ' Activer la première feuille
          .Activate
        End If
        ' Récupérer la ligne de destination
        DerLigD = Sheets("Extraction").Range("A" & Rows.Count).End(xlUp).Row
        ' Copier la ligne mise à jour
        .Rows(Lig).Copy Destination:=Sheets("Extraction").Range("A" & DerLigD + 1)
      End If
    Next Lig
    ' L'analyse des ligne est terminée
    
    ' On exporte la feuille Extraction et on la sauvegarde
    If FlagCréée = True Then
    
'/// modif pmo ///
Sheets("Extraction").Activate
Call Cryptage_Decryptage
'////////////////
    
      Sheets("Extraction").Move
      VPathFic = ThisWorkbook.Path & "\Extraction du " & Format(Now(), "yyyymmdd") & ".xls"
      ActiveWorkbook.SaveAs VPathFic
      ActiveWorkbook.Close
    End If
    ' On mémorise la date d'extraction
    .Range("IQ4").Value = Now()
  End With
End Sub


'///////////////////////////////////////////////////////////////////
'/// Les fonctions CRYPTE et DECRYPTE ont été développées par AV ///
Function CRYPTE(Chaine$) As Variant
Dim x$
Dim i&
For i = 1 To Len(Chaine)
  x = x & Format(Asc(Mid(Chaine, i, 1)), "000") & "08"
Next
CRYPTE = x
End Function
Function DECRYPTE(Chaine$) As Variant
Dim x$
Dim i&
For i = 1 To Len(Chaine) Step 5
  x = x & Chr(Mid(Chaine, i, 3))
Next
DECRYPTE = x
End Function
'///////////////////////////////////////////////////////////////////

Sub Cryptage_Decryptage()
Dim CHAR_RECONNAISSANCE As String
Dim S As Worksheet
Dim R As Range
Dim var
Dim A$
Dim Col&
Dim Lig&
Dim i&
Dim j&
Dim Decryptage As Boolean
Dim bool As Boolean
CHAR_RECONNAISSANCE = Chr(159) & Chr(131) & Chr(138) '= ŸƒŠ
Set S = ActiveSheet
'--- Si il existe un donnée en IV65536, on sort ---
If Not IsEmpty(S.Range("iv65536")) Then
  [iv65536].Select
  MsgBox prompt:="Une donnée existe dans la cellule ''IV65536''.", _
    Buttons:=vbOKOnly + vbCritical, Title:="Programme stoppé (trop long à exécuter)"
  Exit Sub
End If
'--- Recherche de la dernière ligne et de la dernière colonne de la plage ---
For i& = xlByRows To xlByColumns
  Set R = S.Cells.Find(what:="*", after:=[iv65536], SearchOrder:=i&, SearchDirection:=xlPrevious)
  If Not R Is Nothing Then
    A$ = R.Address
    Do
      Set R = S.Cells.FindNext(R)
    Loop While Not R Is Nothing And R.Address <> A$
    If i& = xlByRows Then Lig& = R.Row
    If i& = xlByColumns Then Col& = R.Column
  End If
Next i&
'--- On sort si la feuille est vide ---
If Lig& = 0 Then
  MsgBox "La feuille ''" & S.Name & "'' est vide."
  Exit Sub
End If
'--- Est-ce déjà encrypté ? ---
Set R = S.Range(S.Cells(1, 1), S.Cells(Lig&, Col&))
var = R.Formula
For i& = 1 To Lig&
  For j& = 1 To Col&
    If Left(CStr(var(i&, j&)), Len(CHAR_RECONNAISSANCE)) = CHAR_RECONNAISSANCE Then
      Decryptage = True
      bool = True
      Exit For
    End If
    If bool Then Exit For
  Next j&
Next i&
'--- Mise en tableau des données ---
For i& = 1 To Lig&
  For j& = 1 To Col&
    If Not IsEmpty(var(i&, j&)) And var(i&, j&) <> "" Then
      If Decryptage Then
        var(i&, j&) = CStr(DECRYPTE(CStr(Mid(var(i&, j&), Len(CHAR_RECONNAISSANCE) + 1))))
      Else
        var(i&, j&) = CHAR_RECONNAISSANCE & CStr(CRYPTE(CStr(var(i&, j&))))
      End If
    End If
  Next j&
Next i&

'/// modif pmo ///
'--- Inscription dans la feuille Extraction ---
'Set S = Sheets.Add
Set S = ActiveSheet 'pour votre cas particulier (la feuille Extraction est déja existante)
'/////////////////

    '°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
    '°°° Ne pas utiliser la montée du tableau dans un Range en   °°°
    '°°° un seul coup, à cause de l'erreur 1004 pouvant survenir °°°
    '°°°        (limite de caractères à 912 par exemple).        °°°
    '°°°        Enumérer, plutôt, chaque item du tableau.        °°°
    '°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°
Application.ScreenUpdating = False
For i& = 1 To Lig&
  For j& = 1 To Col&
    S.Range(S.Cells(i&, j&), S.Cells(i&, j&)) = var(i&, j&)
  Next j&
Next i&
Application.ScreenUpdating = True
End Sub

Cordialement.

PMO
Patrick Morange

Byfranck · 25 Juillet 2009

Re : Exporter Excel encrypté

Bonjour PMO2 .. même le samedi ...

J'ai un petit problème j'a beau chercher mais la macro extraction/cryptage ne se lance pas du tout.
Comme bien souvent ce doit être un détail qui se voit comme le nez au milieu de la figure mais plus je cherche moins je vois!
Auriez vous une idée?

PMO2 · 25 Juillet 2009

Re : Exporter Excel encrypté

Bonjour,

J'ai récupéré le .zip de mon message précédent et c'est à partir du classeur qui y est contenu que je viens de faire un test.
Chez moi, tout fonctionne bien et je vois pas ce qui fait obstacle chez vous (???).

Comme vous me le recommandiez dans un de vos messages, avez-vous mis une DATE ANTERIEURE en cellule IQ4 ?

Cordialement.

PMO
Patrick Morange

Byfranck · 25 Juillet 2009

Re : Exporter Excel encrypté

PMO2 à dit:
Comme vous me le recommandiez dans un de vos messages, avez-vous mis une DATE ANTERIEURE en cellule IQ4 ?

Honte sur moi !!!!! 😛

Tellement braqué sur le code que j'en ai oublié mes propres recommandations!

Bien sur maintenant ça fonctionne.

Super merci je vais essayer maintenant de faire une fonction Import/décryptage

Merci encore
Cordialement
Franck

Exporter Excel encrypté

Byfranck

XLDnaute Occasionnel

Pièces jointes

PMO2

XLDnaute Accro

Byfranck

XLDnaute Occasionnel

Byfranck

XLDnaute Occasionnel

PMO2

XLDnaute Accro

Byfranck

XLDnaute Occasionnel

Pièces jointes

PMO2

XLDnaute Accro

Byfranck

XLDnaute Occasionnel

PMO2

XLDnaute Accro

Byfranck

XLDnaute Occasionnel

Discussions similaires

Exporter Excel encrypté

XLDnaute Occasionnel

Pièces jointes

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Accro

XLDnaute Occasionnel

Pièces jointes

XLDnaute Accro

XLDnaute Occasionnel

XLDnaute Accro

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency