Я новичок в создании макросов. Я хочу макрос, который добавляет данные электронной почты в файл Excel и удаляет заголовок почтового сообщения.
Set oTable = oRng.Tables(1)
'And copy it to the clipboard
oTable.Range.Copy
Полный код
Option Explicit
Sub ProcessMessage()
'Graham Mayor 8 June 2015
'This macro is used to process a selection of messages from an Outlook folder
Dim olItem As MailItem
For Each olItem In Application.ActiveExplorer.Selection
'Ensure the selcetd item is an e-mail message
If olItem.Class = OlObjectClass.olMail Then
'Then run the main process
TableToExcel olItem
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
'Tell the user the job is done.
MsgBox "Selected message(s) processed."
Exit Sub
End Sub
Sub TableToExcel(olItem As MailItem)
'Graham Mayor 8 June 2015
'This macro is the main process
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim oTable As Object
Dim strWorkBookName As String
Dim strPath As String
Dim xlRng As Object
Dim LastRow As Long
'Name the folder in which the workbook will reside
strPath = "C:\Path\Tables"
'Name the workbook
strWorkBookName = "Table.xlsx"
'Ensure the folder exists, and if it doesn't run the CreateFolders
'Function to create it.
CreateFolders strPath
With olItem
'Access the message body
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'If there are no tables then end the process
If oRng.Tables.Count = 0 Then GoTo lbl_Exit
'Indicate the first table in the message
Set oTable = oRng.Tables(1)
'And copy it to the clipboard
oTable.Range.Copy
'Close the message
.Close 0
End With
'See if Excel is running and if it is use the running version
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
'Excel is not running, so start it up
Set xlApp = CreateObject("Excel.Application")
End If
'xlApp.Visible = True 'Make true while testing
On Error GoTo 0
'Add a new and empty workbook
Set xlWB = xlApp.workbooks.Open(strPath + strWorkBookName) 'You might want to use a template here?
'Indicate to the process to use the first sheet
Set xlSheet = xlWB.Sheets(1)
LastRow = xlSheet.Range("A1").CurrentRegion.Rows.Count
xlSheet.Range("A" & LastRow + 1).Select
'Paste the clipboard content
xlSheet.Paste
'Optional section to format the table
Set xlRng = xlSheet.UsedRange
With xlRng
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.HorizontalAlignment = 1
.VerticalAlignment = -4160
.Columns.Autofit
End With
'end of optional section
'Ensure the filename doesn't exist and if it does append a
'bracketed number to the name
'Save in the indicated folder
xlWB.SaveAs strPath & strWorkBookName
'Close the workbook
xlWB.Close SaveChanges:=False
lbl_Exit:
'and clean up
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set oTable = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlApp = Nothing
Exit Sub
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor
'A function to create a named path if it doesn't exist
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor
'A function to create unique filenames (works in all Office apps that run VBA)
'strPath is the folder in which the file will be saved e.g. C:\Path\
'strFileName is the original name of the file to be saved
'strExtension is the filename extension e.g. "xlsx", "docx" etc
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
'Graham Mayor
'A function to establish if a file exists
'(works in all Office apps that run VBA)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'A function to establish if a folder exists
'(works in all Office apps that run VBA)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(strFolderName)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function
Спасибо за помощь заранее.