Bonjour,
Cette Macro me permet de répondre à tous a un email avec PJ, et en plus de cela, écrire une message automatique avec l'historique du mail.
OBJECTIF
=======
Mon souhait est d'intégrer au message automatique une donnée située en celulle ("H26") de la Pièce Jointe.
J'arrive bien à lire la donnée lors de l'extration du fichier, mais je n'arrive pas à l'ajouter au texte :
Cette celulle est appellée dans le code :
Je vous remercie infiniement de l'aide que vous pouvez m'apporter.
Voci mon code :
Cette Macro me permet de répondre à tous a un email avec PJ, et en plus de cela, écrire une message automatique avec l'historique du mail.
OBJECTIF
=======
Mon souhait est d'intégrer au message automatique une donnée située en celulle ("H26") de la Pièce Jointe.
J'arrive bien à lire la donnée lors de l'extration du fichier, mais je n'arrive pas à l'ajouter au texte :
Code:
Bonjour,
Votre fiche "celulle ("H26")" est actuellement disponible."
CordialementCette celulle est appellée dans le code :
Code:
Set A = appxl.Range("H26")Je vous remercie infiniement de l'aide que vous pouvez m'apporter.
Voci mon code :
Code:
Sub Repondre_email_avec_PJ()
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Dim i As Long
Dim Att As String
Dim ol As New Outlook.Application
Dim olMail As MailItem
Dim CurrFile As String
Dim Pj As String
Dim OLinbox As Outlook.MAPIFolder '***
Dim myItems As Outlook.Selection '**
On Error Resume Next
Select Case TypeName(Application.ActiveWindow)
Case "Explorer"
Set myItem = ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set myItem = ActiveInspector.CurrentItem
Case Else
End Select
On Error GoTo 0
If myItem Is Nothing Then
GoTo ExitProc
End If
Set olApp = New Outlook.Application '***
Set olSpace = olApp.GetNamespace("MAPI") '*
Set OLinbox = olSpace.GetDefaultFolder(olFolderInbox) '***
Set myDestFolder = OLinbox.Folders("3- TRAITER") '**
Set myItems = ol.ActiveExplorer.Selection '***
Set myAttachments = myItem.Attachments
Set ol = New Outlook.Application
Set outExplorer = Application.ActiveExplorer
Set olMail = outExplorer.Selection.Item(1).ReplyAll
strLink = "http://Site.net"
With olMail
.Subject = "Re:" & myItem.Subject
.Body = "Bonjour," & vbCrLf & vbCrLf & "Votre fiche est actuellement disponible." & vbCrLf & A & vbCrLf & "Cordialement," & vbCrLf & vbCrLf _
& vbCrLf & vbCrLf & vbCrLf _
& "Retrouvez tout sur le site" & " " & strLink & vbCrLf _
& "---------------------------------------------------------------------------------------------------------------------" & vbCrLf & vbCrLf & myItem.Body
End With
CopyAttachments myItem, olMail
olMail.Display
For Each myItem In myItems
myItem.Move myDestFolder
Next myItem
ExitProc:
Set myAttachments = Nothing
Set myItem = Nothing
End Sub
Sub CopyAttachments(objSourceItem, objTargetItem)
Set appxl = CreateObject("Excel.application") '**
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
If Right(objAtt.FileName, 5) = ".xlsx" Or Right(objAtt.FileName, 4) = ".xls" Or Right(objAtt.FileName, 4) = ".zip" Or Right(objAtt.FileName, 5) = ".xlsm" Then
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
appxl.Workbooks.Open strFile '**
appxl.Visible = False '**
Set A = appxl.Range("H26") '**
Debug.Print A '**
appxl.Workbooks.Close '**
fso.DeleteFile strFile
End If
Next
Set appxl = Nothing
Set fldTemp = Nothing
Set fso = Nothing
End Sub
