embedded objects in word (.msg file)

Question

Salve a tutti.

Ho trovato in rete molte domande riguardanti questo argomento, ma ho trovato solo alcuni esempi e mal funzionanti.

In un file word.docx/docm un cliente mi inserisce decine di file .msg di outlook.

Me servirebbe del codice per estrarre questi files .msg in una cartella.

Questo codice a volte funziona altre no e se funziona mi estrae solo il primo file .msg.

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub RunMe()

    Dim olApp As Object, x As Object

    On Error Resume Next

    Set olApp = GetObject(, "Outlook.Application")

    On Error GoTo 0

    If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")

    'close any existing Outlook windows

    For Each x In olApp.inspectors

        x.Close (olDiscard)

    Next

    For Each obj In ActiveDocument.InlineShapes

        Set objole = obj.OLEFormat

        Debug.Print objole.IconLabel

        objole.DoVerb (wdOLEVerbShow)

        SendKeys "{ESC}"

        Sleep 1000

        DoEvents

        For Each x In olApp.inspectors

            Debug.Print x.Caption

            Messaggio = x.Caption

            x.CurrentItem.SaveAs ThisDocument.Path & "\Salvataggio" & Messaggio & ".msg"

            x.Close (olDiscard)

        Next

    Next

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Grazie per eventuali risposte.

Answer 1

Ciao FulvioRobbiani,

è già un risultato! Grazie del cortese riscontro e... Facci conoscere gli sviluppi.

Answer 2

Ciao, sarà spartano ma senza dubbio efficace.

Come dici tu in un commento, i file .msg rimangono aperti, e quindi durante la fase di copia "il comando CopyFile" da un errore 70, che indica appunto l'impossibilità da parte del comando stesso di copiare una file in uso da altro componente.

Ho cercato una funzione del tipo "Activwindows.close" ma non esiste, "Windows.Application.ActiveDocument.Close savechanges = False" mi chiude il file word, contenente i ".msg".

Così al momento ho aggirato l'ostacolo interrompendo l'azione di copia con una msgbox che indica di chiudere Outlook (nel mio esempio ci sono 156 file aperti e chiuderli ad uno ad uno e scocciante).

Dopo di che abbiamo il risultato finale.

Ad un certo momento ho altri messaggi d'errore del tipo "La finestra è già aperta", ma potrebbe essere la conseguenza del problema precedente quando si aprono troppi file.

Grazie 1000 per il tuo aiuto.

Answer 3

Ciao FulvioRobbiani,

un modo, forse un po' barbaro, potrebbe essere questo:

Public Sub Test()

Const strMsgsPath = "D:\Percorso\Msgs"

Dim strTempPath As String

Dim objIlsh     As Word.InlineShape

Dim objOlef     As Word.OLEFormat

Dim strFileName As String

    With ThisDocument

      For Each objIlsh In .InlineShapes

        If objIlsh.Type = wdInlineShapeEmbeddedOLEObject Then

          Set objOlef = objIlsh.OLEFormat

          ' Se compare, come dovrebbe, la finestra:

          ' "Apri contenuto del pacchetto"

          ' Altrimenti van fatti altri ragionamenti...

          '

          SendKeys "{ESC}"

          objOlef.Activate

        End If

      Next

    End With

    strTempPath = Application.Options.DefaultFilePath(wdTempFilePath) _

                & ""

    strFileName = Dir(strTempPath & "*.msg")

    Do While Len(strFileName)

      FileCopy strTempPath & strFileName _

             , strMsgsPath & strFileName

      strFileName = Dir

    Loop

    Set objOlef = Nothing

    Set objIlsh = Nothing

End Sub