Salvare una Mail in Una cartella del computer usando excel.

[Luca73Partecipante Luca73 Karma: 58 pts]

Ciao A tutti,

sto usando Outlook365 ed Excel365

Ho la necessità di salvare la mail archiviate in folder outlook nelle cartelle corrispondenti del computer.

Ho preparato una macro su outlook ma in azienda hanno ben pensato di bloccare le macro su outlook.

L'ho trasferita su Excel ma il comando save as non funziona più (Application-defined or object defined error)

Come posso Risolvere il problema?

La macro è riportata qui sotto, non è bellissima ma funzionava e per il resto funziona. Tra pasentesi [] ho cancellato dati sensibili.

Mi viene il dubbio che il problema sia nel comando saveas che esiste sia in Excel che in Outlook

Sub MailSposta()
Dim objOL As Object
Set objOL = CreateObject("Outlook.Application")
 Dim myFolder
 Dim myNameSpace
 Dim MIOSUBFolder
 Dim MyItem As Object
 Dim MiaDir
 Dim MiaDataLT
 Dim MioNum
 Dim MioTesto
 Dim Pippo
 Dim NomeFile
 Dim NomeFileRid
 Dim Scelta
 Set Pippo = objOL.Explorers
On Error GoTo ErrorGestione
Set myNameSpace = objOL.GetNamespace("MAPI")
Set myFolder = myNameSpace.Folders("[XXX].com").Folders("Cartelle Archivio").Folders("03 Problemi Specifici")
For Each MIOSUBFolder In myFolder.Folders
    Set Pippo = MIOSUBFolder.GetExplorer
    Pippo.Display
    Select Case MsgBox("Procedo con la cartella" & MIOSUBFolder.Name & "?", vbYesNo)
        Case vbYes
            If MIOSUBFolder.Items.Count > 0 Then
                For Each MyItem In MIOSUBFolder.Items
                    MyItem.Display
                    Select Case MsgBox("Salvo il messaggio ?", vbYesNoCancel)
                        Case vbYes
                            MiaDir = Dir("Z:\[...]\05_Pump\" & MIOSUBFolder, vbDirectory)
                            If MiaDir <> "" Then
                                MiaDir = "Z:\[...]\05_Pump\" & MiaDir & "\99 Mails\"
                            Else
                                MiaDir = Dir("Z:\[...]\02_Compressor\" & MIOSUBFolder, vbDirectory)
                                If MiaDir <> "" Then
                                    MiaDir = "Z:\[...]\02_Compressor\" & MiaDir & "\99 Mails\"
                                End If
                            End If
                            If MiaDir = "" Then
                                MsgBox "Cartella Non trovata"
                            Else
                                'MiaDir = "Z:\[...]\05_Pump\" & MiaDir & "\99 Mails\"
                                MiaDataLT = Format(MyItem.ReceivedTime, "yyyy_mm_dd")
                                MioNum = 0
                                NomeFileRid = MyItem.ConversationTopic
                                NomeFileRid = Replace(NomeFileRid, "/", "_")
                                NomeFileRid = Replace(NomeFileRid, "-", "_")
                                NomeFileRid = Replace(NomeFileRid, " ", "")
                                NomeFileRid = Replace(NomeFileRid, ">", "_")
                                NomeFileRid = Replace(NomeFileRid, "<", "_")
                                NomeFileRid = Replace(NomeFileRid, "\", "_")
                                Do
                                    NomeFile = MiaDir & MiaDataLT & "_" & MyItem.ConversationTopic & "_" & Format(MioNum, "00") & ".msg"
                                    MioNum = MioNum + 1
                                Loop While Not (Dir(NomeFile) = "")
                                MyItem.SaveAs NomeFile, 3    'olMSG=3   Outlook message format (.msg)
                                MyItem.GetInspector.Close (True)
                                MyItem.Delete
                            End If
                        Case vbCancel
                            MyItem.GetInspector.Close (True)
                            MyItem.Delete
                        Case vbNo
                            MyItem.GetInspector.Close (True)
                    End Select
                Next MyItem
            End If
            Pippo.Close
            If MIOSUBFolder.Items.Count = 0 Then
                MIOSUBFolder.Delete
            End If
        Case vbCancel
            Pippo.Close
            MIOSUBFolder.Delete
        Case vbNo
            Pippo.Close
        End Select
Next MIOSUBFolder

ErrorGestione:
NomeFile = InputBox("Correggi Nome", "ERRORE", NomeFile)
MyItem.SaveAs NomeFile, 3

Resume Next



End Sub

 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Luca73 ha scritto:

ma il comando save as non funziona più

Il comando SaveAs funziona così come lo hai scritto tu. Ho fatto una prova su un Outlook pulito in macchina virtuale e salva correttamente il messaggio. Bisogna approfondire di più su quel messaggio di errore.

[Autore]

Articoli