Question

我正在为Outlook整理一个VBA宏，并且收到“运行时错误'13'：类型不匹配。我对VBA经验不足，所以我真的可以使用一些帮助。该程序用于导入主题从Outlook的收件箱邮件中可以正常运行，但现在在“下一个olItem”行上出现运行时错误“ 13”。

Sub PullOutlookData()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim ws As Worksheet
Dim lRow As Long
Dim vItem
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")

Set ws = ThisWorkbook.Sheets("OutlookRecord") '<--- relevant worksheet name
Set olItems = olNs.Folders("faizan.farooq@ke.com.pk").Folders("Inbox").Items '<--- RELEVANT FOLDER name
rCount = 1
Sheet14.Range("A1:D2000").Clear
For Each olItem In olItems
    rCount = rCount + 1
    ws.Range("A" & rCount).value = olItem.SenderName
    ws.Range("B" & rCount).value = olItem.Subject

Next olItem
ws.UsedRange.WrapText = False

Call SliceDice
Call FlipColumns

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub
Private Sub test()
    Application.OnTime Now + TimeValue("00:01:00"), "PullOutlookData"
End Sub

Answer 1

代码整理了一下，希望可以解决您的问题...

Sub PullOutlookData()
    On Error GoTo ExitSub
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .EnableEvents = False
    End With
    ActiveSheet.DisplayPageBreaks = False

    Dim olApp As Outlook.Application: Set olApp = New Outlook.Application
    Dim olNs As Outlook.Namespace: Set olNs = olApp.GetNamespace("MAPI")
    Dim Inbox As Outlook.MAPIFolder: Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Dim olItems As Outlook.Items: Set olItems = Inbox.Items

    Dim olItem As Outlook.MailItem
    Dim ws As Worksheet, vItem As Variant, i As Long, rCount As Long

    Set ws = ThisWorkbook.Sheets("OutlookRecord") '<--- relevant worksheet name

    ws.UsedRange.ClearContents
    'Sheet14.Range("A1:D2000").Clear

    rCount = 2
    For i = 1 To olItems.Count
        Set vItem = Inbox.Items.Item(i)
        DoEvents
        If vItem.Class = olMail Then
            ws.Range("A" & rCount) = vItem.SenderName
            ws.Range("B" & rCount) = vItem.Subject
            rCount = rCount + 1    
        End If
        'If i > 100 Then Exit For
    Next i

    ws.UsedRange.WrapText = False

    'Call SliceDice
    'Call FlipColumns

ExitSub:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
    End With
    ActiveSheet.DisplayPageBreaks = True

End Sub

有关类型不匹配的错误

1 个答案: