Envoie de commande DOS sous module VBA Access
Bonjour,
Je cherche à envoyer des commandes dans une fenetre DOS.
J'ai lu le FAQ et le forum VBA mais je n'arrive pas à adapter la solution.
Voici ce à quoi je suis parvenu :
Fonction qui permet de créer un fichier .bat pour enregistrer les commandes à envoyer :
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
| Function soustestFTP()
Dim Repertoire As String
Repertoire = CurrentProject.Path
Repertoire = CStr(Repertoire)
Open Repertoire + "\LoaderSession.bat" For Output As #1
Print #1, "cd.." 'retour repertoire
Print #1, "cd.." 'retour repertoire
Close #1
Sleep 1000
Call TestFTP(Repertoire)
End Function |
Ce code permet de lancer la fonction Shell
Code:
1
2
3
4
5
6
7
8
|
Public Function TestFTP(stSCRFile As String)
Dim stSysDir As String
stSysDir = Environ$("COMSPEC")
stSysDir = Left$(stSysDir, Len(stSysDir) - Len(Dir(stSysDir)))
Call ShellAndWaitForTermination(stSysDir & "cmd.exe -s" & stSCRFile, vbMaximizedFocus, , 5000)
End Function |
Voici la fonction shell
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
Public Function ShellAndWaitForTermination( _
sShell As String, _
Optional ByVal eWindowStyle As VBA.VbAppWinStyle = vbNormalFocus, _
Optional ByRef sError As String, _
Optional ByVal lTimeOut As Long = 3600 _
) As Boolean
Dim hProcess As Long
Dim lR As Long
Dim bSuccess As Boolean
Dim Second As Long
On Error GoTo ShellAndWaitForTerminationError
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(sShell, eWindowStyle))
If (hProcess = 0) Then
'Impossible de lancer la ligne de commande!
sError = "Le programme n'a pu être lancé, vérifiez votre ligne de commande."
Else
bSuccess = True
Second = 0
Do
'Récupération du statut du process,
'on vérifie s'il est terminé (lR = 0).
GetExitCodeProcess hProcess, lR
'Pause en attendant la fin de notre commande sans
'géner l'execution des autres process.
If Second <= lTimeOut Then
DoEvents: Sleep 6000
Second = Second + 1
Else
'Trop long!
Call TerminateProcess(hProcess, lR)
Call CloseHandle(hProcess)
sError = "Trop long: Le process a été stoppé...."
lR = 0
bSuccess = False
End If
Loop While lR = STILL_ACTIVE
End If
ShellAndWaitForTermination = bSuccess
Exit Function
ShellAndWaitForTerminationError:
sError = Err.DESCRIPTION
Exit Function
End Function |
Problème :
La fenetre MSDOS s'ouvre bien avec un repertoire par défault mais impossible d'envoyer les commandes en automatique (cd.. etc)
Pouvez-vous m'aider !
Merci de votre aide
