problème de la boîte de dialogue

Version imprimable

Salut,

la moitié de programme est réalisée mais le problème il m'affiche la boite de dialog et quand je clique sur un fichier il ne me retourne pas son nom et il me génère encore un erreur de type différent,cette fois ci :"la méthode 'BrowseForFolder' de l'objet ' IShellDispatch5' a échoué"

voici mon code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 Sub tets() Dim monraster_src, descrFichier, objFichier, objDialog, OpenFile, strFileName Set monraster_src = CreateObject("Shell.Application") 'Ouverture de la boîte de dialogue pour sélectionner le fichier voulu Set objFichier = monraster_src.BrowseForFolder(&H0&, "Veuillez indiquer le chemin d'accès au fichier" & descrFichier & " à importer", &H4000&) Set objDialog = CreateObject("SAFRCFileDlg.FileOpen") objDialog.OpenFileOpenDlg OpenFile = objDialog.Filename strFileName = objDialog.Filename MsgBox strFileName End Sub
merci d'avance pour vos intervention

Les boites "Ovrir" et "Sauver" ne marchent pas partout.
Pour remédier à cela j'ai crée le code pyramidal suivant (version anglaise avec commentaires en français):

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
'--- Vérife si il y a un composant "Save As/Open" installé ---
On Error Resume Next
Set objDialog = CreateObject("SAFRCFileDlg.FileSave")
	If Err.Number <> 0 Then
	Err.Clear
	Set objDialog = CreateObject("MSComDlg.CommonDialog")
		If Err.Number <> 0 Then
		Err.Clear
		Set objDialog = CreateObject("Jsdlgbox.browser")
			If Err.Number <> 0 Then
			Err.Clear
			Set objDialog = CreateObject("Excel.Application")
				If Err.Number <> 0 Then
				Err.Clear
				MsgBox "None of the ""Save As"" dialog component is installed on this computer." _
					& VbCrlf & "To install the component:" _
					& VbCrlf & "Unzip the content of DlgBox.zip to a folder of your choice and double-click on InstallComponent.vbs." _
					& VbCrlf & "Then delete InstallComponent.vbs and the readme file." _
					& VbCrlf & "If you don't find DlgBox.zip in the plugin package, download the w98 pack." _
					& VbCrlf & "This plugin cannot work without this component installed." ,,0+16,Title
				MsgBox "Action canceled",,Title
				Else
				od=4
				End If
			Else
			od=3
			End If
		Else
		od=2
		End If
	Else
	od=1
	End If
On Error GoTo 0
	Select Case od
	Case 1
		With objDialog 
		.FileName = ""
		.FileType = "Web page complete"
		.OpenFileSaveDlg
		SavedFile = .FileName
		End With
	Case 2
		With objDialog 
		.DialogTitle="Save Webpage As" 
		.Filter="Web page complete|*.html;*.htm|All files|*.*" 
		.MaxFileSize = 250
		.ShowSave 
		SavedFile = .FileName
		End With
	Case 3
		SavedFile = objDialog.savebox
	Case 4
		SavedFile = objDialog.GetSaveAsFilename()
	End Select
od=0
'---- Vérifie la validité du nom de fichier ---
'MsgBox """" & SavedFile & """ Case: " & od,,"debug savedfile"    '---debug
	If SavedFile = "" Or SavedFile = False Then
	Wscript.Quit
	Else
		If InStr(SavedFile, ":")>3 _
		Or InStr(SavedFile, "*")>0 _
		Or InStr(SavedFile, "?")>0 _
		Or InStr(SavedFile, "<")>0 _
		Or InStr(SavedFile, ">")>0 _
		Or InStr(SavedFile, "|")>0 _
		Or InStr(SavedFile, """")>0 Then
		SavedFile = Replace(Replace(Replace(Replace(SavedFile, , ":",""), "*",""), "?",""), "<","")
		SavedFile = Replace(Replace(Replace(Replace(SavedFile, , ">",""), "|",""), "*",""), """","")
		MsgBox "Save path corrected:" & VbCrlf & SavedFile,,Title
		End If
	End If
	If SavedFile = "" Then
	MsgBox "Action canceled.",,Title
	Wscript.Quit
	ElseIf InStr(SavedFile, ".htm")=0 And InStr(SavedFile, ".html")=0 Then
		If InStr(SavedFile, ".")>0 Then
		SavedFile = Left(SavedFile, InStr(SavedFile, ".")-1) & ".htm"
		Else
		SavedFile = SavedFile & ".htm"
		End If
	End If
'--- Fait marcher le script dans le directory ou sera sauvvé/ouvert le fichier (facultatif) ---
WshShell.CurrentDirectory = Left(SavedFile, InStrRev(SavedFile, "\"))

06/09/2009, 17h44
SfJ5Rpw8

Salut, fred...

J'aime bien ta réponse :

juste un problème sur ta dernière ligne facultative (ton objet WshShell n'existe pas ..)

je vais mettre cela dans la TODO pour la mise à jour de la :faq: ... si tu as d'autres codes dans ce genre n'hésite pas à le poster ici ;)

Attends, j'ai amélioré le code:
500 caractères et 22 lignes en moin!

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
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
'---Example pour sauver un document avec l'extention html ----
Select Case 0  '<== c.a.d. zero erreur
	Case CheckObject("nimporte.quoi")
	MsgBox "Non, la, tu reve!",,"test"
	Case CheckObject("SAFRCFileDlg.FileSave")
		With objDialog 
		.FileName = ""
		.FileType = "Web page complete"
		.OpenFileSaveDlg
		SavedFile = .FileName
		End With
	Case CheckObject("MSComDlg.CommonDialog")
		With objDialog 
		.DialogTitle="Save Webpage As" 
		.Filter="Web page complete|*.html;*.htm|All files|*.*" 
		.MaxFileSize = 250
		.ShowSave 
		SavedFile = .FileName
		End With
	Case CheckObject("Jsdlgbox.browser")
		SavedFile = objDialog.savebox
	Case CheckObject("Excel.Application")
		SavedFile = objDialog.GetSaveAsFilename()
	Case Else
	MsgBox "Aucune boite de dialogue ""Ouvrir"" ne marche sur cette foutue bécanne!",,"Erreur"
End Select
'-----Fonction a placé en bas de page si on veut----
Function CheckObject(myObj)
On Error Resume Next
Execute "Set objDialog = createobject(""" & myObj & """)"
CheckObject = Err.Number
If CheckObject = 0 Then '--- debug
MsgBox "Cette objet marche: """ & myObj & """",,"debug"
End If
Err.Clear
On Error GoTo 0
End Function
'------Vérifie la validité du nom de fichier-------
'MsgBox """" & SavedFile & """ Case: " & od,,"debug savedfile"
	If SavedFile = "" Or SavedFile = False Then
	MsgBox "Action canceled.",,"test"
	Wscript.Quit
	Else
		If InStr(SavedFile, ":")>3 _
		Or InStr(SavedFile, "*")>0 _
		Or InStr(SavedFile, "?")>0 _
		Or InStr(SavedFile, "<")>0 _
		Or InStr(SavedFile, ">")>0 _
		Or InStr(SavedFile, "|")>0 _
		Or InStr(SavedFile, """")>0 Then
		SavedFile = Replace(Replace(Replace(Replace(SavedFile, , ":",""), "*",""), "?",""), "<","")
		SavedFile = Replace(Replace(Replace(Replace(SavedFile, , ">",""), "|",""), "*",""), """","")
		MsgBox "Save path corrected:" & VbCrlf & SavedFile,,Title
		End If
	End If
	If InStr(SavedFile, ".htm")=0 And InStr(SavedFile, ".html")=0 Then
		If InStr(SavedFile, ".")>0 Then
		SavedFile = Left(SavedFile, InStr(SavedFile, ".")-1) & ".htm"
		Else
		SavedFile = SavedFile & ".htm"
		End If
	End If
'--------Fait marcher le script dans le directory ou sera sauvé/ouvert le fichier (facultatif)--------
Set WshShell = CreateObject("WScript.Shell")
WshShell.CurrentDirectory = Left(SavedFile, InStrRev(SavedFile, "\"))
MsgBox SavedFile,,"test"

Citation:

Envoyé par tu

juste un problème sur ta dernière ligne facultative (ton objet WshShell n'existe pas ..)

Comme si vous ne saviez ce qu'est WshShell! :mouarf:
(corrigé)