INSTALLER VOTRE PROGRAMME EN TANT QUE SERVICES
skyghis
Messages postés
25
Date d'inscription
mardi 13 août 2002
Statut
Membre
Dernière intervention
26 septembre 2004
-
21 nov. 2002 à 20:13
cs_Multiprise Messages postés 63 Date d'inscription jeudi 4 décembre 2003 Statut Membre Dernière intervention 23 avril 2013 - 23 août 2005 à 15:32
cs_Multiprise Messages postés 63 Date d'inscription jeudi 4 décembre 2003 Statut Membre Dernière intervention 23 avril 2013 - 23 août 2005 à 15:32
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.
https://codes-sources.commentcamarche.net/source/5127-installer-votre-programme-en-tant-que-services
https://codes-sources.commentcamarche.net/source/5127-installer-votre-programme-en-tant-que-services
23 août 2005 à 15:32
C'est l'actvX ServiceNt qui ne fonctionne pas si l'application tente de se créer en tant que service.
Le seul moyen de lancer en autonome une application VB6 est d'utiliser deux utilitaires: INSTSRV.exe & srvany.exe
Si certains sont intéressés, voici le code source de la manip des services.
Ajouter ces deux modules ("ManipServicesNT" et "ModuleGestionRegistres")
à votre code et insérez INSTSRV.exe & SRVANY.exe dans le répertoire de votre application.
Lien de téléchargement de ces deux utilitaires:
http://www.techeez.com/download/2000/instsrv.exe
http://www.techeez.com/download/2000/srvany.exe
------------------------------------------------------
'Module à mettre dans votre code:
'Module "ManipServicesNT"
Option Explicit
'***************************
'Déclaration des constantes
'***************************
Private Const SERVICES_ACTIVE_DATABASE = "ServicesActive"
' Service Control
Private Const SERVICE_CONTROL_STOP = &H1
Private Const SERVICE_CONTROL_PAUSE = &H2
' Service State - for CurrentState
Private Const SERVICE_STOPPED = &H1
Private Const SERVICE_START_PENDING = &H2
Private Const SERVICE_STOP_PENDING = &H3
Private Const SERVICE_RUNNING = &H4
Private Const SERVICE_CONTINUE_PENDING = &H5
Private Const SERVICE_PAUSE_PENDING = &H6
Private Const SERVICE_PAUSED = &H7
'Service Control Manager object specific access types
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SC_MANAGER_CONNECT = &H1
Private Const SC_MANAGER_CREATE_SERVICE = &H2
Private Const SC_MANAGER_ENUMERATE_SERVICE = &H4
Private Const SC_MANAGER_LOCK = &H8
Private Const SC_MANAGER_QUERY_LOCK_STATUS = &H10
Private Const SC_MANAGER_MODIFY_BOOT_CONFIG = &H20
Private Const SC_MANAGER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SC_MANAGER_CONNECT Or SC_MANAGER_CREATE_SERVICE Or SC_MANAGER_ENUMERATE_SERVICE Or SC_MANAGER_LOCK Or SC_MANAGER_QUERY_LOCK_STATUS Or SC_MANAGER_MODIFY_BOOT_CONFIG)
'Service object specific access types
Private Const SERVICE_QUERY_CONFIG = &H1
Private Const SERVICE_CHANGE_CONFIG = &H2
Private Const SERVICE_QUERY_STATUS = &H4
Private Const SERVICE_ENUMERATE_DEPENDENTS = &H8
Private Const SERVICE_START = &H10
Private Const SERVICE_STOP = &H20
Private Const SERVICE_PAUSE_CONTINUE = &H40
Private Const SERVICE_INTERROGATE = &H80
Private Const SERVICE_USER_DEFINED_CONTROL = &H100
Private Const SERVICE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SERVICE_QUERY_CONFIG Or SERVICE_CHANGE_CONFIG Or SERVICE_QUERY_STATUS Or SERVICE_ENUMERATE_DEPENDENTS Or SERVICE_START Or SERVICE_STOP Or SERVICE_PAUSE_CONTINUE Or SERVICE_INTERROGATE Or SERVICE_USER_DEFINED_CONTROL)
'
Type SERVICE_STATUS
dwServiceType As Long
dwCurrentState As Long
dwControlsAccepted As Long
dwWin32ExitCode As Long
dwServiceSpecificExitCode As Long
dwCheckPoint As Long
dwWaitHint As Long
End Type
'
'***********************************************************
' Déclaration des API Windows de manipulation des services
'***********************************************************
Declare Function CloseServiceHandle Lib "advapi32.dll" (ByVal hSCObject As Long) As Long
Declare Function ControlService Lib "advapi32.dll" (ByVal hService As Long, ByVal dwControl As Long, lpServiceStatus As SERVICE_STATUS) As Long
Declare Function OpenSCManager Lib "advapi32.dll" Alias "OpenSCManagerA" (ByVal lpMachineName As String, ByVal lpDatabaseName As String, ByVal dwDesiredAccess As Long) As Long
Declare Function OpenService Lib "advapi32.dll" Alias "OpenServiceA" (ByVal hSCManager As Long, ByVal lpServiceName As String, ByVal dwDesiredAccess As Long) As Long
Declare Function QueryServiceStatus Lib "advapi32.dll" (ByVal hService As Long, lpServiceStatus As SERVICE_STATUS) As Long
Declare Function StartService Lib "advapi32.dll" Alias "StartServiceA" (ByVal hService As Long, ByVal dwNumServiceArgs As Long, ByVal lpServiceArgVectors As Long) As Long
'
'***********************************************************
' Déclaration de l'API Windows de temporisation
'***********************************************************
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'***********************************************************
'Api Windows renvoi le Chemin et Nom court (Compatible MsDos) d'un fichier passé en paramètre
'***********************************************************
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" ( _
ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
'
'
'
'*****************************************************************************************************
' Fonctions et Procédures
'*****************************************************************************************************
'
'--------------------------
'renvoie l'état du service
'--------------------------
Public Function ServiceStatus(ComputerName As String, ServiceName As String) As String
Dim ServiceStat As SERVICE_STATUS
Dim hSManager As Long
Dim hService As Long
Dim hServiceStatus As Long
'
On Error Resume Next
ServiceStatus = ""
hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If hSManager <> 0 Then
hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
If hService <> 0 Then
hServiceStatus = QueryServiceStatus(hService, ServiceStat)
If hServiceStatus <> 0 Then
Select Case ServiceStat.dwCurrentState
Case SERVICE_STOPPED
ServiceStatus = "Arrêté"
Case SERVICE_START_PENDING
ServiceStatus = "En cours de démarrage"
Case SERVICE_STOP_PENDING
ServiceStatus = "En cours d'arrêt"
Case SERVICE_RUNNING
ServiceStatus = "Démarré"
Case SERVICE_CONTINUE_PENDING
ServiceStatus = "En cours de redémarrage"
Case SERVICE_PAUSE_PENDING
ServiceStatus = "En cours de mise en pause"
Case SERVICE_PAUSED
ServiceStatus = "En pause"
End Select
End If
CloseServiceHandle hService
End If
CloseServiceHandle hSManager
End If
End Function
'Mise en pause d'un service
Public Sub ServicePause(ComputerName As String, ServiceName As String)
Dim ServiceStatus As SERVICE_STATUS
Dim hSManager As Long
Dim hService As Long
Dim res As Long
'
On Error Resume Next
hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If hSManager <> 0 Then
hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
If hService <> 0 Then
res = ControlService(hService, SERVICE_CONTROL_PAUSE, ServiceStatus)
CloseServiceHandle hService
End If
CloseServiceHandle hSManager
End If
End Sub
'Démarrage d'un service
Public Sub ServiceStart(ComputerName As String, ServiceName As String)
Dim ServiceStatus As SERVICE_STATUS
Dim hSManager As Long
Dim hService As Long
Dim res As Long
'
On Error Resume Next
hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If hSManager <> 0 Then
hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
If hService <> 0 Then
res = StartService(hService, 0, 0)
CloseServiceHandle hService
End If
CloseServiceHandle hSManager
End If
End Sub
'Arrêt d'un service
Public Sub ServiceStop(ComputerName As String, ServiceName As String)
Dim ServiceStatus As SERVICE_STATUS
Dim hSManager As Long
Dim hService As Long
Dim res As Long
'
On Error Resume Next
hSManager = OpenSCManager(ComputerName, SERVICES_ACTIVE_DATABASE, SC_MANAGER_ALL_ACCESS)
If hSManager <> 0 Then
hService = OpenService(hSManager, ServiceName, SERVICE_ALL_ACCESS)
If hService <> 0 Then
res = ControlService(hService, SERVICE_CONTROL_STOP, ServiceStatus)
CloseServiceHandle hService
End If
CloseServiceHandle hSManager
End If
End Sub
'**************************************************
'Utilisation: Le premier paramètre est le nom de l'ordinateur distant
'Si le nom est une chaîne vide, c'est la machine locale qui est prise en considération
'Le second paramètre est le nom du service
'
'Arrêt d'un service sur machine locale
' ServiceStop "", "Nom du Service"
'Arrêt d'un service sur machine distante
' ServiceStop "\\NomMachine", "Nom du Service"
'Démarrage d'un service
' ServiceStart "", "Nom du Service"
'Mise en pause d'un service
' ServicePause "", "Nom du Service"
'Affichage de l'état d'un service
' MsgBox ServiceStatus("", "Nom du Service")
'********************************************************************************************************************************************************************************************************
Public Sub GestionServices(NomService As String, NomAppli As String, RepertoireAppli As String, Etat As Integer, ModeDemarrage As Integer, Interaction As Boolean, Optional DescriptionService As String)
'********************************************************************************************************************************************************************************************************
Dim compteur As Integer
'NomService => Nom du service tel qu'il doit apparaître dans la liste des services
'NomAppli => Nom de l'application à exécuter en tant que service
'RepertoireAppli => Répertoire ou se trouve l'application à exécuter en tant que service
'Etat 0, 1 ou 2 => Création(1), suppression(0) ou arrêt simple du Service(2)
'ModeDemarrage => (Type de démarrage): 1 = Désactiver (demande de suppression)
' 2 = Automatique
' 3 = Manuel
'Interaction => Autoriser ou non l'application à interagir avec le bureau (Accessible ou non)
'DescriptionService => Description des fonctionnalités du service (texte libre optionnel)
'
'
'Lorsque l'application est exécutée en tant que service
' - Eventuellement, La clef d'autorun est supprimée si elle existe
' - Le service est créé
' - Une clef dans le registre des services est créée
'
On Error Resume Next
'
If Etat 0 Then If NomService "" Or NomAppli = "" Or RepertoireAppli = "" Then Etat = 2
If Etat 1 Then If RepertoireAppli "" Then RepertoireAppli = App.Path
If DescriptionService "" Then DescriptionService NomService
'
If Etat = 0 Then 'arret et suppression du service
'Si le Service Existe
If ServiceStatus("", NomService) <> "" Then
'Arrêt du service
ServiceStop "", NomService
Do While ServiceStatus("", NomService) <> "Arrêté"
Sleep 5
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
MsgBox "Service " & NomService & " " & ServiceStatus("", NomService), vbOKOnly + vbInformation + vbSystemModal
'Suppression de l'application en tant que service
ExecCmd NomCourt(RepertoireAppli) & "\INSTSRV.exe " & NomService & " remove", vbHide
RegDeleteVal "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService & "\Parameters", "Application"
RegDeleteClef "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService & "\Parameters"
RegDeleteClef "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService
'activation de l'autorun si l'application doit se lancer au démarrage (W95 W98 WME) ou à l'ouverture d'une session (WXP W2K WNT)
'RegWriteVal "HKEY_LOCAL_MACHINE", "Software\Microsoft\Windows\CurrentVersion\Run", nomcourt(repertoireappli & "" & Nomappli), Application
End If
ElseIf Etat = 1 Then 'création ou démarrage du service
'Si le service n'est pas créé
If ServiceStatus("", NomService) = "" Then
'Installation de l'application en tant que service
ExecCmd NomCourt(RepertoireAppli) & "\INSTSRV.exe " & NomService & " " & NomCourt(RepertoireAppli) & "\srvany.exe", vbHide
'insciption du chemin et du nom de l'application à exécuter en tant que service
RegWriteVal "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService & "\Parameters", "Application", NomCourt(RepertoireAppli) & "" & NomAppli
'inscription de la description de l'application
RegWriteVal "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService, "Description", DescriptionService
'Modifie éventuellement la clef "Type" en 272 pour activer l'autorisation du service à interagir avec le bureau 16 pour desactiver
If Interaction = True Then
RegWriteValDW "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService, "Type", 272
Else
RegWriteValDW "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService, "Type", 16
End If
'Modifie la clef "Start" en pour paramétrer le type de démarrage
'1=Désactivé 2=Automatique 3=Manuel
RegWriteValDW "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService, "Start", Val(ModeDemarrage)
'suppression de l'autorun si l'application est exécutée au démarrage (W95 W98 WME) ou à l'ouverture d'une session (WXP W2K WNT)
'RegDeleteVal "HKEY_LOCAL_MACHINE", "Software\Microsoft\Windows\CurrentVersion\Run", NomService
'
'démarrage du service
Sleep 50
ServiceStart "", NomService
Do While ServiceStatus("", NomService) <> "Démarré"
Sleep 10
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
MsgBox "Service " & NomService & " " & ServiceStatus("", NomService), vbOKOnly + vbInformation + vbSystemModal
'Modif de la clef pour la prise en compte de l'interaction avec le bureau
If Interaction = True Then
RegWriteValDW "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService, "Type", 16
RegWriteValDW "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & NomService, "Type", 272
End If
'arrêt et redémarrage du service
ServiceStop "", NomService
Do While ServiceStatus("", NomService) <> "Arrêté"
Sleep 10
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
ServiceStart "", NomService
Do While ServiceStatus("", NomService) <> "Démarré"
Sleep 10
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
Else
'démarrage du service
Sleep 50
ServiceStart "", NomService
Do While ServiceStatus("", NomService) <> "Démarré"
Sleep 10
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
ServiceStop "", NomService
Do While ServiceStatus("", NomService) <> "Arrêté"
Sleep 10
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
ServiceStart "", NomService
Do While ServiceStatus("", NomService) <> "Démarré"
Sleep 10
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
MsgBox "Service " & NomService & " " & ServiceStatus("", NomService), vbOKOnly + vbInformation + vbSystemModal
End If
ElseIf Etat = 2 Then 'arret simple du service
'Si le Service Existe
If ServiceStatus("", NomService) <> "" Then
'Arrêt du service
ServiceStop "", NomService
Do While ServiceStatus("", NomService) <> "Arrêté"
Sleep 5
compteur = compteur + 1
If compteur >= 1000 Then Exit Do
Loop
MsgBox "Service " & NomService & " " & ServiceStatus("", NomService), vbOKOnly + vbInformation + vbSystemModal
End If
End If
End Sub
'-----------------------------------------------------
'-----------------------------------------------------
'-----------------------------------------------------
'Module "ModuleGestionRegistres"
Option Explicit
Dim lng As Long
Dim Buff As Long
'Constantes Types de clefs ClefRacine de la base de registres
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_DYN_DATA = &H80000004
'
'Type de données des valeurs de la base de registres
Private Const REG_SZ = 1 ' chaîne Unicode terminée par nul
Private Const REG_EXPAND_SZ = 2 ' chaîne Unicode terminée par nul
Private Const REG_DWORD = 4 ' nombre 32-bit (mot sur 4 octets)
'
' Valeurs de type de création
Private Const REG_OPTION_NON_VOLATILE = 0 'clef préservée lorsque le système est redémarré
'
'- Type Security_Attributes de la base de registres...
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
' Options de sécurité de clef de la base de registres.
Private Const READ_CONTROL = &H20000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
'
' Valeurs renvoyées lors des opérations (écriture, lecture, suppression, création, actualisation)
Private Const ERROR_NONE = 0
Private Const ERROR_BADKEY = 2
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_SUCCESS = 0
'
'****************************************************
'**** API Windows de Gestion des REGISTRES ****
'****************************************************
'Créer ou ouvrir une clef
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
'Supprimer une clef
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String) As Long
'Supprimer une valeur et les données correspondantes dans une clef
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String) As Long
'Lire une valeur et les données correspondantes
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
'Fixer ou créer une valeur avec données ou modifier les données d'une Valeur string
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
ByVal lpData As Any, _
ByVal cbData As Long) As Long
'
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpValue As Long, _
ByVal cbData As Long) As Long
'*****************************************************************
'**** FONCTIONS ET PROCEDURES DE MANIPULATION DES REGISTRES ****
'*****************************************************************
'
'
'Convertis le nom de la ClefRacine (String ou entier) en entier long
'La valeur de la ClefRacine Pouvant être saisie en Numérique ou Alphanumérique
'-----------------------------------------------------------------------------
Private Function ConvertClef(ClefRacine As Variant) As Long
On Error Resume Next
If ClefRacine 0 Or ClefRacine "HKEY_LOCAL_MACHINE" Then ConvertClef = HKEY_LOCAL_MACHINE
If ClefRacine 1 Or ClefRacine "HKEY_CURRENT_USER" Then ConvertClef = HKEY_CURRENT_USER
If ClefRacine 2 Or ClefRacine "HKEY_CLASSES_ROOT" Then ConvertClef = HKEY_CLASSES_ROOT
If ClefRacine 3 Or ClefRacine "HKEY_USERS" Then ConvertClef = HKEY_USERS
If ClefRacine 4 Or ClefRacine "HKEY_DYN_DATA" Then ConvertClef = HKEY_DYN_DATA
End Function
'
'----------------------------------------------------------------
'Créer une nouvelle Clef (Subkey)
'----------------------------------------------------------------
Public Function RegCreateClef(ClefRacine As Variant, Chemin As String) As Long
Dim RetVal As Long
On Error Resume Next
'Suppression éventuelle de l'Anti-Slash (\) qui précède le chemin
If Mid(Chemin, 1, 1) "" Then Chemin Mid(Chemin, 2)
'Ajout éventuel d'un Anti-Slash (\) pour terminer le chemin
If Mid(Chemin, Len(Chemin), 1) <> "" Then Chemin = Chemin & ""
RetVal = RegCreateKey(ConvertClef(ClefRacine), Chemin, lng)
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
RegCreateClef = lng
End Function
'
'-----------------------------------------------------------------
'Supprimer une Clef
'-----------------------------------------------------------------
Public Function RegDeleteClef(ClefRacine As Variant, Chemin As String)
Dim RetVal As Long
On Error Resume Next
'Suppression éventuelle de l'Anti-Slash (\) qui précède le chemin
If Mid(Chemin, 1, 1) "" Then Chemin Mid(Chemin, 2)
'Ajout éventuel d'un Anti-Slash (\) pour terminer le chemin
If Mid(Chemin, Len(Chemin), 1) <> "" Then Chemin = Chemin & ""
RetVal = RegDeleteKey(ConvertClef(ClefRacine), Chemin)
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
End Function
'
'--------------------------------------------------------------------
'Ajouter une Valeur (String)
'--------------------------------------------------------------------
Public Function RegWriteVal(ClefRacine As Variant, Chemin As String, Valeur As String, Donnee As String)
Dim RetVal As Long
On Error Resume Next
Donnee = Trim(Donnee)
If Trim(Donnee) "" Then Donnee " "
'Suppression éventuelle de l'Anti-Slash (\) qui précède le chemin
If Mid(Chemin, 1, 1) "" Then Chemin Mid(Chemin, 2)
'Ajout éventuel d'un Anti-Slash (\) pour terminer le chemin
If Mid(Chemin, Len(Chemin), 1) <> "" Then Chemin = Chemin & ""
RetVal = RegCreateKey(ConvertClef(ClefRacine), Chemin, lng)
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
RetVal = RegSetValueEx(lng, Valeur, 0&, 1, Donnee, Len(Donnee) + 1)
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
RegWriteVal = Donnee
End Function
'
'--------------------------------------------------------------------
'Ajouter une Valeur (Reg DWord)
'--------------------------------------------------------------------
Public Function RegWriteValDW(ClefRacine As Variant, Chemin As String, Valeur As String, Donnee As Long)
Dim RetVal As Long
On Error Resume Next
If Trim(Donnee) "" Then Donnee " "
'Suppression éventuelle de l'Anti-Slash (\) qui précède le chemin
If Mid(Chemin, 1, 1) "" Then Chemin Mid(Chemin, 2)
'Ajout éventuel d'un Anti-Slash (\) pour terminer le chemin
If Mid(Chemin, Len(Chemin), 1) <> "" Then Chemin = Chemin & ""
RetVal = RegCreateKey(ConvertClef(ClefRacine), Chemin, lng)
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
Err.Clear
RetVal = RegSetValueExLong(lng, Valeur, 0&, 4, Donnee, 4)
If Err.Number <> 0 Then Debug.Print Err.Description; Err.Source
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
RegWriteValDW = Donnee
End Function
'
'----------------------------------------------------------------
'Lire une Valeur
'----------------------------------------------------------------
Public Function RegReadVal(ClefRacine As Variant, Chemin As String, Valeur As String) As String
Dim RetVal As Long
On Error Resume Next
'Suppression éventuelle de l'Anti-Slash (\) qui précède le chemin
If Mid(Chemin, 1, 1) "" Then Chemin Mid(Chemin, 2)
'Ajout éventuel d'un Anti-Slash (\) pour terminer le chemin
If Mid(Chemin, Len(Chemin), 1) <> "" Then Chemin = Chemin & ""
Buff = 0
Buff = RegCreateKey(ConvertClef(ClefRacine), Chemin, lng)
If Buff 0 Then RetVal RegQueryValueEx(lng, Valeur, 0&, 1, 0&, Buff)
If Buff < 2 Then 'Si chaine vide
RegReadVal = ""
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
Exit Function
End If
RegReadVal = String(Buff + 1, " ")
RetVal = RegQueryValueEx(lng, Valeur, 0&, 1, ByVal RegReadVal, Buff)
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
RegReadVal = Left(RegReadVal, Buff - 1)
End Function
'
'----------------------------------------------------------------
'Supprimer une Valeur
'----------------------------------------------------------------
Public Function RegDeleteVal(ClefRacine As Variant, Chemin As String, Valeur As String)
Dim RetVal As Long
On Error Resume Next
'Suppression éventuelle de l'Anti-Slash (\) qui précède le chemin
If Mid(Chemin, 1, 1) "" Then Chemin Mid(Chemin, 2)
'Ajout éventuel d'un Anti-Slash (\) pour terminer le chemin
If Mid(Chemin, Len(Chemin), 1) <> "" Then Chemin = Chemin & ""
Buff = 0
Buff = RegCreateKey(ConvertClef(ClefRacine), Chemin, lng)
If Buff 0 Then RetVal RegDeleteValue(lng, ByVal Valeur) Else RetVal = -1
If RetVal = -1 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Inexistante (ERROR_BADKEY)"
If RetVal = 2 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print ClefRacine & "" & Chemin & Valeur & " : " & "Accès Refusé (ERROR_ACCES_DENIED)"
RegDeleteVal = RetVal
End Function
'
'--------------------------------------------------------------------------------
'Activer l'Autorun de l'application en Cours avec passage de paramètres optionnel
'--------------------------------------------------------------------------------
Public Sub RegAutoRunWrite(Optional Parametres As String)
Dim RetVal As Long
On Error Resume Next
'RegWriteVal ConvertClef(ClefRacine), Chemin, Valeur, Donnees
RetVal = RegWriteVal("HKEY_LOCAL_MACHINE", "Software\Microsoft\Windows\CurrentVersion\Run", App.EXEName, App.Path & "" & App.EXEName & ".exe" & " " & Parametres)
If RetVal = 2 Then Debug.Print "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print "Accès Refusé (ERROR_ACCES_DENIED)"
End Sub
'
'----------------------------------------------------------------
'Vérifier si l'Autorun est activé pour l'application en cours
'----------------------------------------------------------------
Public Function RegAutoRunIsActif() As Boolean
On Error Resume Next
'
If RegReadVal("HKEY_LOCAL_MACHINE", "Software\Microsoft\Windows\CurrentVersion\Run", App.EXEName) <> "" Then RegAutoRunIsActif = True Else RegAutoRunIsActif = False
End Function
'
'----------------------------------------------------------------
'Supprimer l'Autorun de l'application en cours
'----------------------------------------------------------------
Public Sub RegAutoRunDelete()
Dim RetVal As Long
On Error Resume Next
RetVal = RegDeleteVal("HKEY_LOCAL_MACHINE", "Software\Microsoft\Windows\CurrentVersion\Run", App.EXEName)
If RetVal = 2 Then Debug.Print "Clef Invalide (ERROR_BADKEY)"
If RetVal = 8 Then Debug.Print "Accès Refusé (ERROR_ACCES_DENIED)"
End Sub
'----------------------------------------------------------------
' Exemples D'utilisation
'----------------------------------------------------------------
' Ecriture d'une Valeur de clef (dans cet exemple on actie l'autorun)
'RegWriteVal "HKEY_LOCAL_MACHINE", "Software\Microsoft\Windows\CurrentVersion\Run", App.EXEName, Application
' Ecriture d'une valeur de clef de type Dword
'RegWriteValDW "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & App.EXEName, "Type", 272
' Lecture d'une valeur de clef
'RegReadVal "HKEY_LOCAL_MACHINE", "SOFTWARE\Data Fellows\F-Secure\Cog-Secure", "ActiveService"
'ou (valclef est de type variant)
'ValClef = RegReadVal("HKEY_LOCAL_MACHINE", "SOFTWARE\Data Fellows\F-Secure\Cog-Secure", "ActiveService")
'Suppression d'une clef
'RegDeleteClef "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & App.EXEName & "\Parameters"
'Suppression d'une Valeur de clef
'RegDeleteVal "HKEY_LOCAL_MACHINE", "SYSTEM\CurrentControlSet\Services" & App.EXEName & "\Parameters", "Application"
'ou (valclef est de type variant)
'ValClef = RegDeleteVal("HKEY_LOCAL_MACHINE", "Software\Microsoft\Windows\CurrentVersion\Run", "Cog-Secure-Client")
25 janv. 2005 à 16:29
21 juin 2003 à 12:13
pk quand j'execute un prog en tant que service win me dit "le prog na pas répondut a la demande de lancement ou de control..." hors je sais meme pas a quoi je doit répondre ny comment et cette erreur arrete aussi sec le service.
pour y remedier je n'ai trouver que cette solution mon service lance un autre prog en Shell qui est lancer lui aussi comme un service mais dont WIn na pas la connaisance le 1 er s'arrete et le 2eme continu normalement....
@++ tlm et bonne prog
23 nov. 2002 à 10:42
21 nov. 2002 à 20:13
alor ca a rien a faire ICI.