Question

I have some code to extract the body of emails in a folder to an .xlsm file. Upon extraction, the file remains open and some reformatting is necessary to split the data out of its cell and to then stack the data in a single column.

This is my first time coding in Outlook VBA, and I feel like there are some fundamental flaws in what I have which may be causing the application-defined error.

Below is the email extraction code:

Sub OutlookToExcel()

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim Msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

strPath = "C:\Users\me\Documents\Action Items\WMV 856 load.xlsm"
Debug.Print strSheet
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(olFolderInbox).Folders("WMV Test")

'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strPath)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(2)
wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set Msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = Msg.Body
intColumnCounter = intColumnCounter + 1
Next itm

'Move items
'   Set Vars
    Dim SubFolder As Outlook.MAPIFolder
    Dim Item As Object
    Dim lngCount As Long
    Dim Items As Outlook.Items

'    Set Items Reference
    Set Items = fld.Items

'   Loop through the Items
    For lngCount = Items.Count To 1 Step -1
        Set Item = Items.Item(lngCount)

        Debug.Print Item.Subject

        If Item.Class = olMail Then
'           // Set SubFolder of Inbox
            Set SubFolder = nms.GetDefaultFolder(olFolderInbox).Folders("WMV Done")
'           // Mark As Read
            Item.UnRead = False
'           // Move Mail Item to sub Folder
            Item.Move SubFolder
        End If
    Next lngCount



SplitTextColumn  <~~~Sub causing errors

MakeOneColumn

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set Msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set Msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

And the data manipulation code (where the error occurs, indicated by <~~~):

**Note: these subs are being called from outlook VBA - could this cause issues?

Sub SplitTextColumn()
'Takes all data out of one cell and splits it by line

    Dim i As Long
    Dim vA As Variant


Dim i As Long
Dim vA As Variant, rng As Range, c As Range
Dim shtNew As Worksheet, sht As Worksheet

Set sht = ActiveSheet

Set rng = sht.Range(sht.Range("A1"), sht.Range("A1").End(xlDown))

For Each c In rng.Cells
    vA = Split(c.Value, vbLf)
    c.Offset(0, 1).Resize(1, UBound(vA) + 1).Value = vA '<~~~ Error on this line

Next

Set shtNew = Sheets.Add(After:=sht)

sht.Range("A1").CurrentRegion.Offset(0, 1).Copy

shtNew.Range("a1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=True


    End Sub

Answer 1

通常你应该尽可能避免使用选择/选择（而且你的代码中很少需要它）

尝试这样的事情：

function isInteger(input){
    Number.isInteger(input)
}

Number.isInteger = Number.isInteger || function(value) {
  return typeof value === "number" && 
    isFinite(value) && 
    Math.floor(value) === value;
};

Application-defined or object-defined error performing excel functions in Outlook VBA

1 个答案: