[VB6] Messaggi Outlook in arrivo salvati automaticamente in file di testo

[Virus1978]

Salve a tutti,
premessa: sono completamente ignorante in VB.
È possibile far si che un messaggio (il body) che arriva da un determinato mittente venga salvato automaticamente in un file di testo (txt) in una determinata cartella?

Grazie mille

[alka]

Di quale versione di VB parliamo? Letto il Regolamento?

[Virus1978]

I messaggi arrivano su Outlook 2003 e la versione di visual basic ad esso collegato e la 6.3

[andreaciao_22]

io ho fatto un programma che mi salva via in una cartella le newsletter che mi arrivano da HTML.IT(compresi allegati), modifica il codice mettendo al posto del cid la path dell'allegato corrispondente e mi visualizza la newsletter in Internet Explorer. ti può interessare?
uso Outlook 2002 ma va bene anche su Outlook 2003

[Virus1978]

wow, mi interesserebbe. Spero non sia già troppo complicato per me. A me arrivano i cambi delle valute ogni giorno e in outlook è già in formato testo. Devo averlo in formato txt su file esterno per poterlo elaborare con un database oracle.

[andreaciao_22]

Programma VBA di salvataggio mail HTML

Riferimenti: 
Microsoft Scripting RunTime
Microsoft Internet Controls

‘Nel modulo di classe ThisWorkbook
Private WithEvents colNews As Outlook.Items
Private Sub Application_Quit()
    On Error Resume Next
    Set colNews = Nothing
    Set FSO = Nothing
    Set myNS = Nothing
End Sub

Private Sub Application_Startup()
    Dim FoldNews As Outlook.MAPIFolder
    Call SettaItem
    Set FoldNews = myNS.GetDefaultFolder(olFolderInbox).Folders("NewsLetter") 
    Set colNews = FoldNews.Items
    Set FoldNews = Nothing
    swFatto = False
    If colNews.Count > 0 Then Call Inizia
End Sub

Private Sub colNews_ItemAdd(ByVal Item As Object)
    Call SalvaHTMLMail(Item)
End Sub

Sub Inizia()
    Dim Ele As Outlook.MailItem, i As Integer, Cont As Long
    Cont = colNews.Count
    For i = Cont To 1 Step -1
        Set Ele = colNews(i)
        Call SalvaHTMLMail(Ele)
        Set Ele = Nothing
    Next
End Sub
‘in un modulo a parte
Public myNS As Outlook.NameSpace
Public MyArchivio As MAPIFolder
Public Utente As String
Public UtenteMapi As String
Public FSO As Scripting.FileSystemObject
Sub SettaItem()
    If myNS Is Nothing Then Set myNS = Application.GetNamespace("Mapi")
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
    Utente = Environ$("UserName")
    UtenteMapi = Application.Session.CurrentUser
End Sub

Sub SalvaHTMLMail(ByVal Item As Object)
    Dim arrSubject As Variant, F As Scripting.TextStream, Att As Attachment, strFold As String
    Dim j As Integer, strPathAtt As String
    Dim ContaAtt As Integer, t As Integer, strHtml As String, swModificato As Boolean
    Dim CercaCID As String, TrovatoCID As Long, NumFile As Integer, PercorsoFile As String
    arrSubject = Array("JavaScript", "CSS", "Programmazione", "Microsoft Dev", "Grafica e design") ‘cartelle sul disco riguardanti il subject della newsletter
    swModificato = False
    For j = 0 To UBound(arrSubject)
        If InStr(1, Item.Subject, arrSubject(j), vbBinaryCompare) > 0 Then
            strFold = "E:\andrea\Posta\" & arrSubject(j)
            If Len(Trim$(Dir$(strFold, vbDirectory))) = 0 Then
                MkDir strFold
                MkDir strFold & "\Immagini"
            End If
            strHtml = Item.HTMLBody ‘per formato testo usare la proprietà Body e cancellare fino alla freccia
            ContaAtt = Item.Attachments.Count
            For t = ContaAtt To 1 Step -1
                Set Att = Item.Attachments(t)
                strPathAtt = strFold & "\Immagini\" & Att.FileName
                If Len(Trim$(Dir(strPathAtt))) > 0 Then Kill strPathAtt
                Att.SaveAsFile strPathAtt
                TrovatoCID = InStrRev(strHtml, "cid:", , vbTextCompare)
                CercaCID = Mid$(strHtml, TrovatoCID)
                CercaCID = Mid$(CercaCID, 1, InStr(1, CercaCID, Chr(34)) - 1)
                strHtml = Replace(strHtml, CercaCID, strPathAtt)
                Set Att = Nothing
                DoEvents
            Next 
            NumFile = FreeFile
            PercorsoFile = strFold & "\" & Format(Date, "dd-mm-yyyy") & ".htm" ‘nome file = data odierna
            If Len(Trim$(Dir(PercorsoFile))) > 0 Then Kill PercorsoFile
            Set F = FSO.CreateTextFile(PercorsoFile)
            F.Write strHtml
            F.Close
            Set F = Nothing
            swModificato = True
            Exit For
        End If
    Next
    If swModificato = True Then ‘se tutto è andato a buon fine, cancello la mail e apro il browser
        Item.Delete
        Call ApriBrowser(PercorsoFile, True)
    End If
End Sub

‘in un altro modulo
Option Explicit

Const ENUM_CURRENT_SETTINGS As Long = -1&
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Public Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Sub ApriBrowser(ByVal strUrl As String, Optional blToolbar As Boolean = False)
    Dim Web As SHDocVw.InternetExplorer, Schermo As DEVMODE
    Call EnumDisplaySettings(0&, ENUM_CURRENT_SETTINGS, Schermo)
    Set Web = CreateObject("InternetExplorer.Application")
    With Web
        .Width = Schermo.dmPelsWidth * (90 / 100)
        .Height = Schermo.dmPelsHeight * (90 / 100)
        .Top = Schermo.dmPelsHeight * (5 / 100)
        .Left = Schermo.dmPelsWidth * (5 / 100)
        .Resizable = False
        .MenuBar = False
        .StatusBar = False
        .AddressBar = False
        .Toolbar = blToolbar
        .Visible = True
        .Navigate strUrl
    End With
    Set Web = Nothing
End Sub

Se avete consigli o se manca qualcosa o errori vari contattatemi

[Virus1978]

mmm, speravo di riuscire a semplificarlo per le mie esigenze ma niente.
C'è qcs di più semplice?

[andreaciao_22]

se mi dici cosa deve fare il programma, te lo semplifico io....