tenho um script em vba, que salva todos os anexos que contem dentro de determinado email, gostaria de fazer uma ligação desses anexos com o endereco de que envio os anexo, criar uma pasta com o nome do endereco de email, e enviar os anexos para ela, segue meu codigo em vba, se alguém poder me ajudar.
Public Sub AttachmentIndex()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim sAppName As String
Dim sSection As String
Dim sKey As String
Dim lRegValue As Long
Dim lFormValue As Long
Dim iDefault As Integer
sAppName = "Outlook"
sSection = "Index"
sKey = "Last Index Number"
iDefault = 101
lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
If lRegValue = 0 Then lRegValue = iDefault
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
Set objOL = Application
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "C:\Temp\Anexos Outlook\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile = objAttachments.Item(i).FileName
lcount = InStrRev(strFile, ".") - 1
pre = Left(strFile, lcount)
ext = Right(strFile, Len(strFile) - lcount)
strFile = strFolderpath & pre & "_" & lRegValue & ext
objAttachments.Item(i).SaveAsFile strFile
lRegValue = lRegValue + 1
Err.Clear
Next
SaveSetting sAppName, sSection, sKey, lRegValue
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
