Fichier Patients - Création auto des répertoires et liens hypertextes

[jlg1964]

Bonjour,

Pour refondre l'organisation de mon fichier Patients et réorganiser les différents dossiers leur correspondants sur mon disque dur, j'ai décidé de centraliser sur ce fichier Excel un minimum d'informations qui me permette d'accéder facilement aux données les concernant. Je me retrouve avec plus de 9.000 dossiers patients classés aujourd'hui d'une façon relativement aléatoire . Ce qui me fait perdre un temps que vous imaginez ! A l'occasion de mon passage sur un nouveau PC (le précédent avait 9 ans et fonctionnait avec Windows XP) j'ai décidé de reprendre cette organisation d'une façon rationnelle. Malheureusement, cette ambition échoue - pour l'instant - au test de la maîtrise de fonctions d'Excel !
Je vous remercie donc de l'aide que vous pourrez m'apporter pour résoudre l'équation suivante :

Sur mon disque dur, les dossiers patients sont organisés de la façon suivante :
- un index alphabétique de A à Z à l'intérieur duquel mes patients sont classés par dossiers de type "NOM_Prénom" (NOM espace Prénom).
- à l'intérieur de chaque dossier patients, des sous-dossiers dont les intitulés correspondent aux colonnes "G" à "O"
- Exemple : Mme Françoise GIRAUDOUX apparaitra ainsi sur mon Disque : "F:\Patients\G\GIRAUDOUX Jean. Le dossier "GIRAUDOUX Jean" comporte 9 sous-dossiers (intitulés des colonnes G à O)

Mon problème est le suivant : je souhaite chaque fois que je crée un intitulé "Patient" avoir la possibilité d'appeler une fonction qui me permette de créer automatiquement :
- le dossier patient sur mon disque dur, ainsi que les sous-dossiers associés,
- un lien hypertexte du dossier patient dans la cellulle "Cn" de mon tableau,
- un lien hypertexte vers chacun des sous-dossiers dans les cellules "G" à O" dudit patient,
- et enfin il faudrait qu'en cas d'homonymie parfaite entre deux patients, l'intitulé du dossier patient soit assorti d'un numéro d'ordre.

Mon document actuel (joint) donne un aperçu de l'organisation générale à laquelle je souhaite parvenir. La colonne A calcule la valeur du répertoire Index dans lequel le dossier patient devra être créé. La colonne Y (fonction concaténer) calcule la valeur à donner au dossier du patient.

J'ai vu dans ce forum un certain nombre de contributions qui me laissent penser que cela est possible, mais je n'arrive pas à en faire une synthèse qui fonctionne, la cardiologie m'étant manifestement plus familière qu'Excel !

Merci d'avance pour votre aide ! Celle-ci pourra peut-être servir à d'autres praticiens qui traversent les mêmes difficultés que moi. J'espère avoir été suffisamment précis dans l'exposé de mon besoin, mais je suis prêt à répondre à toutes les demandes de précisions supplémentaires, bien entendu !

A titre indicatif, Mon PC fonctionne sous Windows 7 Pro 64 bits, et j'utilise la suite Office 2010.

JLG

 

[Dormeur74]

Re : Fichier Patients - Création auto des répertoires et liens hypertextes

Et bien doc, je me doutais que ce serait intéressant. Donc tu commences à avoir de la matière ; bonne chose.
Je me suis un peu penché sur le DMP. Il existe un simulateur sur la toile construit pour les patients et pour les professionnels de la santé. Tu pourras le trouver Ce lien n'existe plus. Je l'ai téléchargé (92 Mo) mais n'ai pas réussi à le faire fonctionner, même après avoir pris contact avec l'informaticien qui gère le système (un jeune, sympa et très disponible). Si tu as un pb pour finaliser ton outil, n'hésite pas à prolonger ce fil.

 

[jlg1964]

Re : Fichier Patients - Création auto des répertoires et liens hypertextes

Super Dormeur74, j'investigue (néologisme ?) et je ferai part de mes résultats dans ce fil !

 

[Dormeur74]

Re : Fichier Patients - Création auto des répertoires et liens hypertextes

Nous vivons dans un monde libre ou les néologismes ont droit de cité.
Donc tu investigues. Si les humeurs de tes patients t'en laissent le temps, tu nous dis.
Au passage, je crois beaucoup au DMP pour des raisons qui n'ont rien à voir avec Excel.

 

[laurent950]

Re : Fichier Patients - Création auto des répertoires et liens hypertextes

Bonsoir Docteur,

Suite à mon premier poste je joins le fichier Excel qui vous constituera votre base de Données pour les 9 000 documents.

C'est un peu technique à expliquer mais je joins cette macro pour mes ami(e)s du forum qui m'ont beaucoup aidé et qui pourront aussi y contribuer.

C’est un peu long à mettre en place j'ai un peux travaillé sur le sujet et peu être qu’il est possible améliorer cette macro.

Voilà le code : (Fichier joint au message qui sera personnalisé à votre besoin en fonction de votre description).

Donc le module standard :

Option Explicit
Option Compare Text
Public Type InfosResultFichiers
    NomFich As String                 ' Nom du fichier
    CheminFich As String               ' Chemin du Fichier
    TailleOctFich As Long              ' Taille en octets du fichier
    DateCreaFich As Date               ' Date création du fichier
    DateModFich As Date                ' Date dernière modification du fichier
    TypeFich As String              ' Type du fichier
End Type

 Sub Main()
 ' Explorateur de fichier dans windows
 
 Application.ScreenUpdating = False
 
 ' Mémoire classeur et feuille
 Dim F1 As Worksheet
 Set F1 = Worksheets("BaseDonnees")
 
 ' Variable
 Dim i As Long
 
 'Déclaration de la Variable "Recheche" et initialisation de cette variable a la classe "ClasseFileSearch"
 Dim Recherche As ClasseFileSearch
 Set Recherche = New ClasseFileSearch
 ' suite idéme
 Dim RepertSource As ChoixRepertoire
 Set RepertSource = New ChoixRepertoire
  ' suite idéme
' Dim TabFiles As VarTabTyp
' Set TabFiles = New VarTabTyp
 
Dim Fin As Long
Fin = F1.Range("A65536").End(xlUp).Row
F1.Range(Cells(2, 1), Cells(Fin + 1, 50)).Clear

With Recherche
    ' Choix du repertoire
    Dim RacineDoss As String
    RacineDoss = RepertSource.OuvertureRepertoire
        
        'Définit le répertoire de recherche
        .ReptSource = RacineDoss
 
        'Définit la recherche dans les sous dossiers (True / False)
        .ReptSousDoss = True
 
        'Option de tri:
        '(Sort_None, sort_Name, sort_Path, sort_Size, sort_DateCreaFich, sort_LastModified, sort_Type)
        'Pas de tri si le paramètre n'est pas spécifié.
        '.SortBy = sort_Name
 
        'Option pour rechercher un type de fichier
        '(Renvoie tous les fichiers si non spécifié)
        '.Extension = "*.doc"
 
        'Execute la recherche
        .Execute

        'Boucle sur le tableau pour afficher le résultat de la recherche
        '(.CpteurLignTableau renvoie le nombre de fichiers trouvés)
        
        ' Correspondance
        Dim Lettre()
        Dim pos()
        Dim j As Integer
        Lettre = Array("Courriers", "ECG", "Eeff", "Bio", "Holter", "MAPA", "Echo", "Vasc", "Divers")
        pos = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
        
        For i = 1 To .CpteurLignTableau
        
        Dim chem, nam As String
        Dim Tabl() As String
        Dim Tabl2() As String
        chem = .NumLignTab(i).CheminFich
        Tabl = Split(chem, "\")
        nam = Tabl(UBound(Tabl) - 1)
        Tabl2 = Split(nam, " ")
        
        Dim lign As Long
        If F1.Cells(lign + 1, 25) <> nam Then
            lign = lign + 1
        End If
        
                For j = 0 To UBound(Lettre)
                    If Lettre(j) = Tabl(UBound(Tabl)) Then
                      ' Index = Lettre du Patient
                        F1.Cells(lign + 1, 1) = Tabl(2)
                      ' Remplissage de la base "Nom et Prémom"
                        F1.Cells(lign + 1, 3) = Tabl2(0)
                        F1.Cells(lign + 1, 5) = Tabl2(1)
                        F1.Cells(lign + 1, 25) = nam
                      ' X pour le chemin d'acces au fichier
                        F1.Cells(lign + 1, 6 + pos(j)) = "X"
                      ' Crée les liens
                        F1.HyperLinks.Add Anchor:=F1.Cells(lign + 1, 6 + pos(j)), Address:=.NumLignTab(i).CheminFich
                        'Cells(i + 1, 6 + UBound(Tabl)) = .NumLignTab(i).NomFich
                        'Cells(i + 1, 2) = .NumLignTab(i).TailleOctFich
                        'Cells(i + 1, 3) = .NumLignTab(i).DateCreaFich
                        'Cells(i + 1, 4) = .NumLignTab(i).DateModFich
                        'Cells(i + 1, 5) = .NumLignTab(i).TypeFich
                        'Cells(i + 1, 6 + UBound(Tabl)) = .NumLignTab(i).CheminFich
                    End If
                Next j
        Next i

End With
 
Application.ScreenUpdating = True
 
 End Sub

Module de class associer

Function OuvertureRepertoire()

'-------------------------------------------------------------------------------------------------------------------------------------------------------------------
'                             I) Ouverture de L'explorateur de fichier (Pour les fichiers du répertoire Sources)
'                                                 Récupération des données + Nom du répertoire
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------

' Boucle d'ouverture vers Répertoire fichiers sources
    Dim objShell1 As Object
    Dim objFolder1 As Object
    Dim oFolderItem1 As Object
    Dim CheminSource As String
    
    Set objShell1 = CreateObject("Shell.Application")
    MsgBox "Choix du Repertoire Source"
    Set objFolder1 = objShell1.BrowseForFolder(&H0&, "Tous les Fichiers du Repertoire seront Listé", &H1&)

    On Error Resume Next
    Set oFolderItem1 = objFolder1.Items.Item
    CheminSource = oFolderItem1.Path
    OuvertureRepertoire = CheminSource
    
End Function

autres modules de class associer

Option Explicit
Option Compare Text
Option Base 1

Private mReptSource As String                     ' N°1 Répertoire de recherche
Private mReptSousDoss As Boolean                  ' N°2 Propriété pour rechercher dans les sous dossiers
Dim mCpteurLignTableau As Long                    ' N°4 compteur pour Redimensionne le tableau et lui ajouter un nouvel élément
Dim strExtens As String

Dim TabFiles() As InfosResultFichiers             ' N° 5 TabFiles c'est le tableau typé
' N°1 Répertoire de recherche
Public Property Let ReptSource(ReptSource As String)
    ' Propriété en écriture
        mReptSource = ReptSource
End Property

'N°2 Propriété pour rechercher dans les sous dossiers
Public Property Let ReptSousDoss(ReptSousDoss As Boolean)
    ' Propriété en écriture
        mReptSousDoss = ReptSousDoss
End Property

' Propriété pour lister les fichiers correspondants à la requête du tableau "i" correspond au i dans le main
Public Property Get NumLignTab(i As Long) As InfosResultFichiers
    NumLignTab = TabFiles(i)
End Property

'Propriété pour l'extension des fichiers à rechercher
Public Property Let extension(strExtension As String)
    strExtens = strExtension
End Property

'Propriété pour compte le nombre de fichiers
Public Property Get CpteurLignTableau() As Long
    CpteurLignTableau = mCpteurLignTableau
End Property
' N°3 Fonction d'exécution
Public Function Execute() As Long
    'Lance la recherche
    ListeFichiers mReptSource
    ' Renvois
    Execute = mCpteurLignTableau
End Function

' N°3 Suite Procédure pour lister les fichiers
Private Sub ListeFichiers(strFolderName As String)
Dim Fso As Object
Dim NomDossier As Object
Dim SousDossier As Object
Dim objFichier As Object

On Error GoTo Fin

'Vérifie si le dossier spécifié existe
If Dir(strFolderName, vbDirectory Or vbHidden Or vbSystem) = "" Then
    Exit Sub
End If

Set Fso = CreateObject("Scripting.FileSystemObject")
Set NomDossier = Fso.GetFolder(strFolderName)

'Boucle sur les fichiers du répertoire
For Each objFichier In NomDossier.Files

'Vérifie l'extension du fichier
    If objFichier.Name Like strExtens Or strExtens = "" Then
    
        'Redimensionne le tableau pour ajouter un nouvel élément
        mCpteurLignTableau = mCpteurLignTableau + 1
        ReDim Preserve TabFiles(mCpteurLignTableau)
        
            'Nom fichier
            TabFiles(mCpteurLignTableau).NomFich = objFichier.Name
            'Répertoire
            TabFiles(mCpteurLignTableau).CheminFich = objFichier.ParentFolder
            'Taille du fichier (en octets)
            TabFiles(mCpteurLignTableau).TailleOctFich = objFichier.Size
            'Date de création
            TabFiles(mCpteurLignTableau).DateCreaFich = objFichier.DateCreated
            'Date de création ou dernière modification
            TabFiles(mCpteurLignTableau).DateModFich = objFichier.DateLastModified
            'Type de fichier
            TabFiles(mCpteurLignTableau).TypeFich = objFichier.Type
    End If
Next objFichier

'Boucle récursive:
'(Si l'option de recherche dans les sous répertoires a été spécifiée)
If mReptSousDoss Then
    For Each SousDossier In NomDossier.SubFolders
        ListeFichiers SousDossier.Path
    Next SousDossier
End If

Exit Sub:

Fin:
    MsgBox "Erreur '" & Err.Number & "'" & vbCrLf & vbCrLf & _
    Err.Description, vbInformation
End Sub

Pouvez-vous me dire si cela vous correspond ?

Ce travail est intéressant à adapter.

Pour la création des dossiers automatiques je n'y vois pas l'intérêt ou l'idée qui peuvent me conduire à une astuce, car c’est la suite de ce premier module qu’il faudrait synchroniser en fonction de votre réponse par rapport à ce premier essai.
Dans l’attente de votre réponse je pourrai effectuer la suite du programme en fonction de votre orientation.

Laurent

 

[praveshdoc]

Re : Fichier Patients - Création auto des répertoires et liens hypertextes

bonjour a tous. je suis medecin. et je vois que le excel sur ce forum est juste geniale. je voudrais sa coir comment faire pour ajouter un nouveau item par exemple bilan optalmo..etc