Mail joindre fichier url
Bonjour,
Afin de bien comprendre ma demande je joint mon fichier qui fonctionne bien.
Le seul problème que j'ai c'est qu'a partir du moment ou je choisi en E17 (menu déroulant) un lien réseau, et que je clique sur le bouton "Envoyer" la fenêtre d'importation d'un fichier ne se rend pas au bon endroit.
en C:\Users pas de problème ainsi que C:\Windows
Je n'ai pas donné trop d'information vous comprendrez mieux en utilisant le fichier.
Merci pour votre aide.
bonjour,
essaie ceci (chdir pour un lecteur sur le PC doit se faire en 2 temps si changement de lecteur (un chdir pour le lecteur puis un chdir pour le répertoire) et ne fonctionne pas pour des lecteurs réseaux. Utilise pour cela une fonction système windows.
#If VBA7 Then
Private Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
#Else
Private Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
#End If
Public Sub EnvoiAutomatiqueMail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim adresse As String
Dim sPath As String
Dim sAdrMail As String, strSujet As String, strBody As String
Dim SigString As String, Signature As String
Dim copie As String
Dim message As String
Dim sujet As String
Dim i As Integer
Parcourir
For Y = 6 To 12
If (Sheets("MAIL").Range("A" & Y).Value <> "") Then 'verfier le nombre d'adresse mail
adresse = adresse & Sheets("MAIL").Range("A" & Y).Value & ";"
End If
If (Sheets("MAIL").Range("B" & Y).Value <> "") Then 'verfier le nombre d'adresse mail en copie
copie = copie & Sheets("MAIL").Range("B" & Y).Value & ";"
End If
Next Y
With Sheets("MAIL")
sujet = Cells(6, "C")
strBody = "<HTML>"
strBody = strBody & "<HEAD>"
strBody = strBody & "<BODY>"
strBody = strBody & .Cells(6, "D") & "<br><br>" & .Cells(6, "E") & "<br><br>" & .Cells(6, "F") & "<br><br>"
sPath = Environ("appdata") & "\Microsoft\Signatures\"
SigString = Dir(sPath & "*.htm")
' Signature = GetBoiler(sPath & SigString)
Set OutlookApp = CreateObject("outlook.application")
Set OutlookMail = OutlookApp.createitem(0)
With OutlookMail
.Subject = sujet
.To = adresse
.CC = copie
.Attachments.Add (Sheets("MAIL").Range("E17").Value & nomFichier)
.HTMLBody = strBody & "<br><br>" & Signature
.Display
End With
End With
End Sub
Sub Parcourir()
Dim fName As String, wb As Workbook
SetCurrentDirectoryA (Sheets("MAIL").Range("E17").Value) ' Path can be a network directory
fName = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If fName = "Faux" Then End
'''''''''''''''''''''''''''''''''''''''''' Verifier si le fichier est correct via la cellule A1 ="VIN"''''''''''''''''''''''
tmpStr = Split(fName, "\")
nomFichier = tmpStr(UBound(tmpStr))
End SubMerci pour ton aide
Effectivement au moment de parcourir il va directement dans le bon dossier et une fois le fichier choisi il faite une erreur sur cette ligne
.Attachments.Add (Sheets("MAIL").Range("E17").Value & nomFichier)bonjour,
vérifie s'il ne manque pas un "\" entre le répertoire et le nom de fichier
C'est présent
Mais j'ai fait d'une autre manière
à la place de l'appel de la macro "Parcourir", J'ai mis la macro directement
Public Sub EnvoiAutomatiqueMail()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim adresse As String
Dim sPath As String
Dim sAdrMail As String, strSujet As String, strBody As String
Dim SigString As String, Signature As String
Dim copie As String
Dim message As String
Dim sujet As String
Dim i As Integer
Dim nomFichier As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim fName As String, wb As Workbook
SetCurrentDirectoryA (Sheets("MAIL").Range("E17").Value) ' Path can be a network directory
fName = Application.GetOpenFilename("Excel Files (*.xls), *.xlsx")
If fName = "Faux" Then End
tmpStr = Split(fName, "\")
nomFichier = tmpStr(UBound(tmpStr))
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For Y = 6 To 12
If (Sheets("MAIL").Range("A" & Y).Value <> "") Then 'verfier le nombre d'adresse mail
adresse = adresse & Sheets("MAIL").Range("A" & Y).Value & ";"
End If
If (Sheets("MAIL").Range("B" & Y).Value <> "") Then 'verfier le nombre d'adresse mail en copie
copie = copie & Sheets("MAIL").Range("B" & Y).Value & ";"
End If
Next Y
With Sheets("MAIL")
sujet = Cells(6, "C")
strBody = "<HTML>"
strBody = strBody & "<HEAD>"
strBody = strBody & "<BODY>"
strBody = strBody & .Cells(6, "D") & "<br><br>" & .Cells(6, "E") & "<br><br>" & .Cells(6, "F") & "<br><br>"
sPath = Environ("appdata") & "\Microsoft\Signatures\"
SigString = Dir(sPath & "*.htm")
' Signature = GetBoiler(sPath & SigString)
Set OutlookApp = CreateObject("outlook.application")
Set OutlookMail = OutlookApp.createitem(0)
With OutlookMail
.Subject = sujet
.To = adresse
.CC = copie
.Attachments.Add (fName)
.HTMLBody = strBody & "<br><br>" & Signature
.Display
End With
End With
End SubPar contre il ne me fait pas d'erreur mais j'ai cette ligne en rouge :
Private Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
bonjour,
cette instruction est pour la version 32bits (pour le cas où ce code devrait à la fois tourner sur une version excel 32 bits ou 64 bits.
Si tu n'en as pas besoin, remplace ceci
#If VBA7 Then
Private Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
#Else
Private Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
#End Ifpar ceci
Private Declare PtrSafe Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As LongMerci
C'est parfais :)