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 86 87 88 89 90 91
| Option Compare Database
Dim Un_Marché_Affiché as Boolean
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Public Function GetExcelPath(ByVal Filename As String) As String
Dim strBuffer As String
strBuffer = String(260, 32)
If FindExecutable(Filename, vbNullString, strBuffer) > 32 Then
GetExcelPath = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If
End Function
Function CheminCible() As String
Dim straBureau(1 To 2) As String
Dim strChemin As String
Dim C As Integer
straBureau(1) = "Bureau\"
straBureau(2) = "Desktop\"
For C = 1 To 2
strChemin = Environ("USERPROFILE") & "\" & straBureau(C)
If Len(Dir(strChemin, vbDirectory)) Then
Exit For
End If
Next
CheminCible = strChemin
End Function
Sub Export_Excel_F_Conslt()
On Error GoTo Erreur
'Initialisations
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
[...]
' code de fermeture et libération des objets
strChemin = CheminCible()
' regarde si le fichier existe et si oui, lui donne un numéro
If Un_Marché_Affiché = True Then
If Fichier_Existe(strChemin & "\MP Accessor " & Form_F_Conslt_F.Référence & ".xlsx") = True Then
For I = 2 To 20
If Fichier_Existe(strChemin & "MP Accessor " & Form_F_Conslt_F.Référence & " (" & I & ").xlsx") = False Then
xlBook.SaveAs strChemin & "MP Accessor " & Form_F_Conslt_F.Référence & " (" & I & ").xlsx"
Exit For
End If
Next I
Else
xlBook.SaveAs strChemin & "MP Accessor " & Form_F_Conslt_F.Référence & ".xlsx"
End If
Else
If Fichier_Existe(strChemin & "MP Accessor Fournitures.xlsx") = True Then
For I = 2 To 20
If Fichier_Existe(strChemin & "MP Accessor Fournitures (" & I & ").xlsx") = False Then
xlBook.SaveAs strChemin & "MP Accessor Fournitures (" & I & ").xlsx"
Exit For
End If
Next I
Else
xlBook.SaveAs strChemin & "MP Accessor Fournitures.xlsx"
End If
End If
'Fin de la procédure
strXLFileName = xlBook.Name
MSG = MsgBox(" --- Opération réussie ---" & vbNewLine & vbNewLine & _
"Le fichier Excel se trouve sur le bureau avec pour nom : " & xlBook.Name & "." _
& vbNewLine & vbNewLine & "Voulez-vous ouvrir ce fichier ?", vbYesNo, "Exportation des données")
xlBook.Close
xlApp.Quit
Set Enreg_F = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
'Propose d'ouvrir le fichier Excel nouvellement créé
If MSG = vbYes Then
dblSuccess = Shell(Chr(34) & GetExcelPath(strXLFileName) & Chr(34) & " " & Chr(34) & strXLFileName & Chr(34), 1)
MsgBox "Résultat du Shell : " & dblSuccess, , "Test"
End If
Exit Sub
Erreur:
MsgBox ("Erreur n°" & Err.Number & vbNewLine & Err.Description)
End Sub |