Soyez le premier à donner votre avis sur cette source.
Snippet vu 5 884 fois - Téléchargée 50 fois
'------------------------------------------------------------------------------------------------------ '---------- 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
Pitié! fais nous un source zippé pour que ca puisse servir au moins aux personnes qui 'nont pas 24h a passer sur un script kom ca!
Parce que chez moi ca marche pas du tout! Déja ta oublié la déclaration du shellexecute ds le module de l'application et appremment tu t planté ds les passages de paramètres de cette même fonction...
Elors envoi un zip su tu veux bien,
ciao,
merci quand meme vieux :Þ
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.