Salve,
Ho provato a cercare qui ma non sono riuscito a trovare,perchè vorrei spostare gli email da leggere in Excel con le stringhe specifiche da estrarre in una cella.
E' possibile?
Grazie.
ciao
Davide
Moderatori: Anthony47, Flash30005
Option Explicit
Private strTemplatesPath As String
Public Sub SaveMessagesToExcel()
'Created by Helen Feddema 5-Sep-2007
'Last modified 5-Sep-2007
'Demonstrates pushing mail message data to rows in an Excel worksheet
On Error GoTo ErrorHandler
Dim appExcel As New Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim i As Integer
Dim j As Integer
Dim lngCount As Long
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
'Must declare as Object because folders may contain different
'types of items
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String
strTemplatesPath = GetTemplatesPath
strSheet = "Messages.xls"
strSheet = strTemplatesPath & strSheet
Debug.Print "Excel workbook: " & strSheet
'Test for file in the Templates folder
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Messages.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If
Set wkb = appExcel.Workbooks.Open(strSheet)
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Let user select a folder to export
On Error Resume Next
SelectMailFolder:
Set fld = nms.PickFolder
Debug.Print "Folder item type: " & fld.DefaultItemType
If fld Is Nothing Then
GoTo ErrorHandlerExit
ElseIf fld.DefaultItemType <> olMailItem Then
strPrompt = "Please select a Mail folder"
strTitle = "Folder error"
MsgBox prompt:=strPrompt, _
Buttons:=vbExclamation + vbOKOnly, _
Title:=strTitle
GoTo SelectMailFolder
End If
On Error GoTo ErrorHandler
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No messages to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " messages to export"
End If
'Adjust i (row number) to be 1 less than the number of the first body row
i = 3
'Iterate through contact items in Contacts folder, and export a few fields
'from each item to a row in the Contacts worksheet
For Each itm In fld.Items
If itm.Class = olMail Then
'Process item only if it is a mail item
Set msg = itm
i = i + 1
'j is the column number
j = 1
Set rng = wks.Cells(i, j)
If msg.To <> "" Then rng.Value = msg.To
j = j + 1
Set rng = wks.Cells(i, j)
If msg.cc <> "" Then rng.Value = msg.cc
j = j + 1
Set rng = wks.Cells(i, j)
If msg.SenderEmailAddress <> "" Then rng.Value = msg.SenderEmailAddress
j = j + 1
Set rng = wks.Cells(i, j)
If msg.Subject <> "" Then rng.Value = msg.Subject
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.SentOn
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.ReceivedTime
j = j + 1
Set rng = wks.Cells(i, j)
If msg.Categories <> "" Then rng.Value = msg.Categories
j = j + 1
Set rng = wks.Cells(i, j)
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
If msg.UserProperties("CustomField") <> "" Then
rng.Value = msg.UserProperties("CustomField")
End If
j = j + 1
End If
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number _
& " in SaveMessagesToExcel procedure; " _
& "Description: " & Err.Description
Resume ErrorHandlerExit
End Sub
Public Function TestFileExists(strFile As String) As Boolean
'Created by Helen Feddema 9-1-2004
'Last modified 9-1-2004
'Tests for existing of a file, using the FileSystemObject
Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File
On Error Resume Next
Set fil = fso.GetFile(strFile)
If fil Is Nothing Then
TestFileExists = False
Else
TestFileExists = True
End If
End Function
Public Function GetTemplatesPath() As String
'Created by Helen Feddema 5-Sep-2007
'Last modified 5-Sep-2007
Dim appWord As Word.Application
Set appWord = GetObject(, "Word.Application")
strTemplatesPath = _
appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"
Debug.Print "Templates folder: " & strTemplatesPath
GetTemplatesPath = strTemplatesPath
ErrorHandlerExit:
Set appWord = Nothing
Exit Function
ErrorHandler:
If Err = 429 Then
'Word is not running; open Word with CreateObject
Set appWord = CreateObject("Word.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " _
& Err.Description
Resume ErrorHandlerExit
End If
End Function
Option Explicit
Private Sub Workbook_Open()
'Created by Helen Feddema 28-Oct-2010
'Last modified by Helen Feddema 29-Oct-2010
On Error GoTo ErrorHandler
Dim appOutlook As Outlook.Application
Dim nms As Outlook.Namespace
Dim lngCount As Long
Dim itm As Object
Dim msg As Outlook.MailItem
Dim i As Integer
Dim fld As Outlook.MAPIFolder
Dim rng As Excel.Range
Dim j As Integer
Dim wks As Excel.Worksheet
Dim strPrompt As String
Dim strTitle As String
Dim intReturn As Integer
Dim strPath As String
Dim intPath As Integer
Dim intExt As Integer
Dim intLength As Integer
Dim strBody As String
Dim varResult As Variant
strTitle = "Question"
strPrompt = "Import mail messages?"
intReturn = MsgBox(prompt:=strPrompt, _
Buttons:=vbQuestion + vbYesNo, _
Title:=strTitle)
If intReturn = vbNo Then
GoTo ErrorHandlerExit
End If
'Let user select a folder to import
Set appOutlook = GetObject(, "Outlook.Application")
Set nms = appOutlook.GetNamespace("MAPI")
Set fld = nms.PickFolder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If
'Test whether selected folder contains mail messages
If fld.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain mail messages"
GoTo ErrorHandlerExit
End If
lngCount = fld.Items.Count
If lngCount = 0 Then
MsgBox "No messages to import"
GoTo ErrorHandlerExit
Else
Set wks = Application.ActiveSheet
Debug.Print lngCount & " messages to import"
End If
'Adjust i (row number) to be 1 less than the number of the first body row
i = 3
'Iterate through items in selected folder, and import a few fields
'from each item to a row in the worksheet
For Each itm In fld.Items
If itm.Class = olMail Then
'Process item only if it is a mail item
Set msg = itm
i = i + 1
'j is the column number
j = 1
Set rng = wks.Cells(i, j)
If msg.To <> "" Then rng.Value = msg.To
j = j + 1
Set rng = wks.Cells(i, j)
If msg.cc <> "" Then rng.Value = msg.cc
j = j + 1
Set rng = wks.Cells(i, j)
If msg.SenderEmailAddress <> "" Then rng.Value = msg.SenderEmailAddress
j = j + 1
Set rng = wks.Cells(i, j)
If msg.Subject <> "" Then rng.Value = msg.Subject
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.SentOn
j = j + 1
Set rng = wks.Cells(i, j)
rng.Value = msg.ReceivedTime
j = j + 1
Set rng = wks.Cells(i, j)
If msg.Body <> "" Then
strBody = msg.Body
rng.Value = strBody
End If
j = j + 1
Set rng = wks.Cells(i, j)
varResult = InStr(strBody, "[b].png[/b]")
If IsNull(varResult) = False And varResult > 0 Then
intPath = CInt(varResult)
End If
varResult = InStr(strBody, "[b]Thanks[/b]")
If IsNull(varResult) = False And varResult > 0 Then
intExt = CInt(varResult)
intLength = intExt - intPath [b]+ 10[/b]
strPath = Mid(strBody, intPath, intLength)
Debug.Print "Path string: " & strPath
Else
strPath = ""
End If
If strPath <> "" Then
Set rng = wks.Cells(i, j)
rng.Value = strPath
End If
j = j + 1
End If
Next itm
ErrorHandlerExit:
Exit Sub
ErrorHandler:
'Outlook is not running; open Outlook with CreateObject
If Err.Number = 429 Then
Set appOutlook = CreateObject("Outlook.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number _
& " in Workbook_Open procedure; " _
& "Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub
Sub GetOlTables()
'Importa su un nuovo file Excel le tabelle contenute nella mail selezionata
'il file non viene salvato e rimane apert all'interno di Excel per le successive fasi
'
Dim myMail As MailItem, myHTM As HTMLDocument, myEx As Object
Dim myWB As Object
'
Set myHTM = New MSHTML.HTMLDocument
Set myMail = GetItem
myHTM.Body.innerHTML = myMail.HTMLBody
'
On Error Resume Next
Set myEx = GetObject(, "Excel.Application")
On Error GoTo 0
If myEx Is Nothing Then Set myEx = CreateObject("Excel.Application")
myEx.Visible = True
'myEx.workbooks.Add '***Crea nuovo Workbook
myEx.Workbooks.Open "C:\Users\UTENTE1\Documents\PEPPA.xls" '***<<<OPPURE, lavora su uno esistente
myEx.Sheets("Foglio2").Select
myEx.Range("A:H").ClearContents
myEx.Range("A:H").NumberFormat = "@"
'
Set mycoll = myHTM.getElementsByTagName("TABLE")
For Each myItm In mycoll
For Each trtr In myItm.Rows
For Each tdtd In trtr.Cells
myEx.Cells(I + 1, J + 1) = tdtd.innerText
J = J + 1
Next tdtd
I = I + 1: J = 0
Next trtr
I = I + 1
Next myItm
myEx.Range("A:H").WrapText = False
'
Set myMail = Nothing
Set myHTM = Nothing
'
End Sub
Function GetItem() As Object
'crea riferimento a mail "corrente", che sia selezionata o aperta
Dim OlApp As Outlook.Application
'
Set OlApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(OlApp.ActiveWindow)
Case "Explorer"
Set GetItem = OlApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetItem = OlApp.ActiveInspector.CurrentItem
Case Else
'Qui non dovrebbe finirci...
End Select
Set OlApp = Nothing
End Function
Dim myEx As Object, myI As Long, myJ As Long, myMail As MailItem
Sub ScanM()
Dim toTale As Long, I As Long
'
toTale = Application.ActiveExplorer.CurrentFolder.Items.Count
myI = 0: myJ = 0
'
On Error Resume Next
Set myEx = GetObject(, "Excel.Application")
On Error GoTo 0
If myEx Is Nothing Then Set myEx = CreateObject("Excel.Application")
myEx.Visible = True
'myEx.workbooks.Add '***Crea nuovo Workbook
myEx.Workbooks.Open "C:\Users\UTENTE1\Documents\PEPPA.xls" '***<<<OPPURE, lavora su uno esistente
myEx.Sheets("Foglio2").Select
myEx.Range("A:H").ClearContents
myEx.Range("A:H").NumberFormat = "@"
'
'Scan delle mail:
For I = 1 To toTale
Set myMail = Application.ActiveExplorer.CurrentFolder.Items.Item(I)
Call GetAllTables(0)
Next I
myEx.Range("A:H").WrapText = False
'
End Sub
Sub GetAllTables(byVal Dummy)
'Importa su un nuovo file Excel le tabelle contenute nella mail selezionata
'il file non viene salvato e rimane apert all'interno di Excel per le successive fasi
'
Dim myHTM As HTMLDocument
Dim myWB As Object
'
Set myHTM = New MSHTML.HTMLDocument
''Set myMail = GetItem 'ora e' in ScanM
myHTM.Body.innerHTML = myMail.HTMLBody
'
'Rimosso blocco per apertura Applicazione File Excel (-->in ScanM)
'
'Aggiunte next 2:
myEx.cells(myI + 1, 1) = ">>>>>>>>>> " & myMail.ReceivedTime: myEx.cells(myI + 1, 2) = myMail.Subject
myI = myI + 1
Set mycoll = myHTM.getElementsByTagName("TABLE")
For Each myItm In mycoll
For Each trtr In myItm.Rows
For Each tdtd In trtr.cells
myEx.cells(myI + 1, myJ + 1) = tdtd.innerText
myJ = myJ + 1
Next tdtd
myI = myI + 1: myJ = 0
Next trtr
myI = myI + 1
Next myItm
myEx.Range("A:H").WrapText = False
'
Set myMail = Nothing
Set myHTM = Nothing
'
End Sub
Torna a Applicazioni Office Windows
Excel: formula automatica per evidenziare prodotto scaduto Autore: gamma_ray |
Forum: Applicazioni Office Windows Risposte: 3 |
Salvare file excel in formato html escludendo le immagini Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 10 |
formula excel non visualizza risultato Autore: tommasog |
Forum: Applicazioni Office Windows Risposte: 6 |
Excel 2016 - Funzione SCARTO + INDIRETTO Autore: pl1957 |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: raimea e 15 ospiti