Mise a jour automatique d'un projet (vertion fonctionnant en lan uniquement)

Commenter

Contenu du snippet

le but est d'ajouter a vos projets la possibilitée de se mettre a jour automatiquement si une vertion plus récente est trouvée sur le réseau

votre projet doit posseder un indice de vertion (un numerot arbitraire), cet indice sera comparré a celui trouvé sur le réseau. la mise a jour se ferra seulement si l'indice trouvé sur le réseau est plus grand que l'indice de la vertion utilisée

explications :

--- 1 ---
  • il faut créer un projet "AutoUpdate" qui contiendra le form "Path_Window" et le module "ModAu"
  • dans ce projet, ajouter la référence à "Microsoft Scripting Runtime", et définire "Sub Main" comme point de démarrage de l'application
  • une foi AutoUpdate.exe compilé, le placer dans le meme répertoire que l'exe de votre projet


--- 2 ---
  • inclure le module "mAutoUpdate" à votre projet
  • définire "Sub Main" comme point de démarrage de votre projet
  • placer dans les premieres lignes de la fonction "Form_Load()" de votre Form principal la ligne : SaveSetting "<nom du projet>", "au", "ver", "<indice de version>"
  • dans le module"mAutoUpdate", mettez le bon nom de projet dans le ligne :

auVer = GetSetting("<nom du projet>", "au", "ver", "-1")
  • dans le module"mAutoUpdate", mettez le bon nom de projet dans le ligne :

commandLine = " /T=" & auExePath & "/E=" & App.EXEName & ".exe /V=" & auVer & " /P=<nom du projet>"

--- 3 ---
  • sur le réseau, partager un répertoire qui contiendra les fichiers a copier pour la mise a jour
  • dans ce répertoire, placer tous les fichiers a copier, et créer un fichier texte que vous nomerez "AU.DTA"
  • le fichier "AU.DTA" doit contenir en première ligne l'indice de la vertion disponible, et chaque ligne supplementaire doit contenir le nom d'un fichier a copier par ligne


--- exemple de fichier "AU.DTA" ----
  • sur les postes clients est installé votre projet, dont l'indice est 1
  • vous décidez de faire une mise a jour du fichier exe de votre projet, ainsi que du fichier "hello.bmp"
  • dans le répertoire partagé, vous placez le fichier exe a copier et le fichier "hello.bmp"
  • dans le fichier "AU.DTA" vous mettez :

"2" en première ligne
"<le nom de votre exe>" en deusième ligne
"hello.bmp" en troisième ligne
  • au lancement de votre exe sur le poste client, la mise a jour se fera automatiquement

Source / Exemple : 


'------------------------------------------------------------------------------------------------------
'----------               module "ModAu" à ajouter au projet "Autoupdate"               -----------
'------------------------------------------------------------------------------------------------------

Option Explicit

Public Declare Function ShellExecute Lib "Shell32" Alias "ShellExecuteA" (ByVal hwnd As Long, _
    ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    
Public retour_PathWnd As String ' valeur de retour de la from Path_Window

Dim g_from As String            ' chemin d'orrigine de la mise a jour
Dim g_to As String              ' chemin de destination de la mise a jour

Dim g_exeName As String         ' nom du fichier exe a lancer a la fin de l'opération de mise a jour

Dim g_actuelVer As String       ' indice de la version actuellement utilisée
Dim g_nextVer As String         ' indice de la version disponible sur le réseau

Dim g_nom_projet As String      ' nom du projet pour la save dans la registry

Dim fso As Scripting.FileSystemObject ' objet fso
'

Sub Main()
' execution principale :
' 1 recupere les arguments passé a autoupdate.exe
' 2 vérifie que l'on connais l'emplacement du fichier AU.DTA
' 3 sinon demande le chemin a l'utilisateur
' 4 vérifie si une vertion plus récente du projet existe sur le réseau
' 5 effectue la mise a jour du projet si besoin
' 6 puis relance le projet

    Set fso = CreateObject("Scripting.FileSystemObject")

    ' recupere la liste d'arguments

    If Not GetArglList Then _
        RunExe
        
    ' recupere le chemin de mise a jour
    
    If Not GetUpdatePath Then _
        RunExe
        
    If Mid(g_from, Len(g_from)) <> "\" Then g_from = g_from & "\"
    
    ' verifie les versions
    
    If Not CheckNewVer Then _
        RunExe
    
    ' met a jour
    
    Update
    
    RunExe
    
End Sub

Private Function GetUpdatePath() As Boolean
' recupere le chemin du fichier AU.DTA depuis la registry ou depuis l'entrée utilisateur
    
    Dim temp_path As String

    GetUpdatePath = False
    
    ' recupere depuis la registry
    
    temp_path = GetSetting("AutoUpdate", "Paths", g_nom_projet, "")
    If CheckUpdatePath(temp_path) Then
        
        g_from = temp_path
        GetUpdatePath = True
        Exit Function
        
    End If
    
    ' demande en boucle a l'utilisateur jusqu'a avoir trouvé le fichier, ou jusqu'a annulation
    
    Do While (1)
    
        ' demande a l'utilisateur
           
        Path_Window.l_PathIn = temp_path
        retour_PathWnd = ""
        
        Path_Window.Show 1
        
        ' vérifie la réponse
        
        temp_path = retour_PathWnd
        
        If temp_path = "cancel" Then _
            Exit Function
            
        If CheckUpdatePath(temp_path) Then
            
            g_from = temp_path
            SaveSetting "AutoUpdate", "Paths", g_nom_projet, temp_path
            GetUpdatePath = True
            Exit Function
            
        End If
        
        
    Loop

End Function

Private Function CheckUpdatePath(ByVal PathToCheck As String) As Boolean
' vérifie la présence du fichier AU.DTA

    CheckUpdatePath = False
    
    ' chaine vide ?
    
    If Len(PathToCheck) = 0 Then _
        Exit Function
        
    ' fichier présent ?
        
    If Mid(PathToCheck, Len(PathToCheck)) <> "\" Then _
        PathToCheck = PathToCheck & "\"
        
    If Not fso.FileExists(PathToCheck & "au.dta") Then _
        Exit Function
        
    CheckUpdatePath = True

End Function

Private Function GetArglList() As Boolean
' recupère la liste des arguments passés a autoupdate.exe

    Dim command_str As String, arg_tab() As String, temp_tab() As String, _
        i As Long
    
    GetArglList = False
    command_str = Trim(Command)
    g_to = ""
    g_exeName = ""
    g_actuelVer = ""
    
    ' vérif d'entrée

    If Len(command_str) = 0 Then
        MsgBox "La ligne de commande est vide !", vbCritical + vbOKOnly
        Exit Function
    End If
    
    If InStr(command_str, "/") = 0 Or InStr(command_str, "=") = 0 Then
        MsgBox "La ligne de commande est vide !", vbCritical + vbOKOnly
        Exit Function
    End If
    
    ' séparre chaque argument
    
    arg_tab = Split(command_str, "/")
    
    ' envoi chaque argument a la fonction GetOneArg()
    
    For i = 0 To UBound(arg_tab)
    
        If InStr(arg_tab(i), "=") <> 0 Then
        
            temp_tab = Split(arg_tab(i), "=")
            
            GetOneArg Trim(temp_tab(0)), Trim(temp_tab(1))
            
            Erase temp_tab
        
        End If
    
    Next
    
    Erase arg_tab
    
    ' verifie que tous les arguments sont présents
    
    If Len(g_to) = 0 Or Len(g_exeName) = 0 Or Len(g_actuelVer) = 0 Or Len(g_nom_projet) = 0 Then
        MsgBox "La ligne de commande est vide !", vbCritical + vbOKOnly
        Exit Function
    End If
    
    ' correction des chemins de répertoires
    
    If Mid(g_to, Len(g_to), 1) <> "\" Then g_to = g_to & "\"
        
    GetArglList = True
    
End Function

Private Sub GetOneArg(ByVal str_Var As String, ByVal str_Val As String)
' fonction utilisée par GetArglList() pour recuperrer la valeur de chaque ellements

    If Len(str_Var) = 0 Or Len(str_Val) = 0 Then _
        Exit Sub
    
    str_Var = UCase(str_Var)
    ' destination de la copie
    If str_Var = "T" Then
        g_to = str_Val
    ' nom de l'exe a lancer a la fin de l'opération
    ElseIf str_Var = "E" Then
        g_exeName = str_Val
    ' indice de vertion actuellement uilisée
    ElseIf str_Var = "V" Then
        g_actuelVer = str_Val
    ' nom du projet pour save dans registry
    ElseIf str_Var = "P" Then
        g_nom_projet = str_Val
    End If

End Sub

Private Function CheckNewVer() As Boolean
' ouvre le fichier AU.DTA pour y lire l'indice de vertion disponible sur le réseau
' comparre a l'indice de vertion utilisée

    Dim fileStream As Scripting.TextStream
    
    CheckNewVer = False
    
    ' fichier présent ?
    
    If Not fso.FileExists(g_from & "au.dta") Then _
        Exit Function
        
    ' lit la première ligne du fichier AU.DTA
    
    Set fileStream = fso.OpenTextFile(g_from & "au.dta")
    g_nextVer = fileStream.ReadLine
    fileStream.Close
    Set fileStream = Nothing
    
    ' vérifie les variables
    
    If Not (IsNumeric(g_actuelVer) Or IsNumeric(g_nextVer)) Then _
        Exit Function
        
    ' compare
        
    If CLng(g_nextVer) > CLng(g_actuelVer) Then _
        CheckNewVer = True

End Function

Private Function Update()
' fonction de copie pour la mise a jour

    Dim fileStream As Scripting.TextStream, tab_files() As String, all_txt As String, _
        i As Long, temp_txt As String
        
    ' lit tout le fichier AU.DTA
    
    Set fileStream = fso.OpenTextFile(g_from & "au.dta")
    all_txt = fileStream.ReadAll
    fileStream.Close
    Set fileStream = Nothing
    
    ' copie fichier par fichier
    
    tab_files = Split(all_txt, vbCrLf)
    
    For i = 1 To UBound(tab_files)
    
        temp_txt = Trim(tab_files(i))
        
        If Len(temp_txt) <> 0 Then
            If fso.FileExists(g_from & temp_txt) Then _
                fso.CopyFile g_from & temp_txt, g_to & temp_txt
        End If
        
    Next
    
    Erase tab_files

End Function

Private Sub RunExe()
' lance l'EXE avec le paramettre "auok"

    Set fso = Nothing
    
    ShellExecute 0, "open", g_to & g_exeName, "auok", g_to, 1
    
    End

End Sub

'------------------------------------------------------------------------------------------------------
'----------               Form "Path_Window" à ajouter au projet "Autoupdate"               ------
'----------                                                                                                            ------
'---------- le form doit contenir un champ texte nommé "txtPath", ainsi qu'un bouton ------
'---------- OK nommé "cmdOk" et un bouton Annuler nommé "cmdCancel"               ------
'------------------------------------------------------------------------------------------------------

Option Explicit

Public l_PathIn As String       ' le chemin d'entrée si il doit etre indiqué

Private Sub cmdCancel_Click()

    ModAU.retour_PathWnd = "cancel"
    Unload Path_Window
    
End Sub

Private Sub cmdOk_Click()

    Dim temp_txt As String
    
    temp_txt = Trim(txtPath.Text)
    
    If Len(temp_txt) = 0 Then
        MsgBox "Veuillez fournir un chemin"
        txtPath.SetFocus
        Exit Sub
    End If
    
    If Len(temp_txt) > 5 Then
        If UCase(Mid(temp_txt, Len(temp_txt) - 5)) = "AU.DTA" Then _
            temp_txt = Mid(temp_txt, 1, Len(temp_txt) - 6)
    End If
    
    If Mid(temp_txt, Len(temp_txt), 1) <> "\" Then temp_txt = temp_txt & "\"
    
    If Not ModAU.fso.FileExists(temp_txt & "au.dta") Then
        MsgBox "Le fichier AU.DTA est introuvable a l'emplacement spécifié"
        txtPath.SetFocus
        Exit Sub
    End If
    
    ModAU.retour_PathWnd = temp_txt
    Unload Path_Window
    
End Sub

Private Sub Form_Load()

    txtPath.Text = l_PathIn
    
End Sub

'------------------------------------------------------------------------------------------------------
'----------          module "mAutoUpdate" à ajouter a vote projet                        -----------
'------------------------------------------------------------------------------------------------------

Option Explicit
'

Sub Main()

    Dim fso As Scripting.FileSystemObject, auVer As String, _
        auExePath As String, commandLine As String

    On Error GoTo catch_err
    
    ' vérifie si on as les options de l'autoupdate en registry
    
    auVer = GetSetting("<nom du projet>", "au", "ver", "-1")
    
    ' vérifie si la ligne de commande indique que l'update est effectué
    
    If (InStr(Command, "auok") > 0) Then
    
        Main_Window.Show 0
        
    Else
    
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        auExePath = App.Path
        If Mid(auExePath, Len(auExePath), 1) <> "\" Then auExePath = auExePath & "\"
        
        ' vérifie la presence du fichier autoupdate.exe
        
        If fso.FileExists(auExePath & "AutoUpdate.exe") Then
        
            Set fso = Nothing
            
            commandLine = " /T=" & auExePath & "/E=" & App.EXEName & _
                ".exe /V=" & auVer & " /P=<nom du projet>"

            ShellExecute 0, "open", auExePath & "AutoUpdate.exe", commandLine, auExePath, 1
            End
            
        ' le fichier autoupdate.exe n'existe pas -> lance l'appli normalement
        
        Else
        
            Set fso = Nothing
            
            Main_Window.Show 0
            
        End If
        
    End If
    
    Exit Sub
    
catch_err:

    If Err.Number <> 364 Then

        If MsgBox("Erreur dans la fonction mAutoUpdate.Main()" & vbCrLf & vbCrLf & _
            "Error Number : " & Err.Number & vbCrLf & _
            "Source : " & Err.Source & vbCrLf & vbCrLf & _
            "Description : " & Err.Description & vbCrLf & vbCrLf & _
            "Ok pour continuer, Annuler pour interrompre.", _
            vbCritical + vbOKCancel, "Erreur") = vbCancel Then End
            
    End If
        
    Err.Clear

End Sub

Conclusion :


b_bouchet@club-internet.fr pour plus de details

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.