Excel VBA检测Outlook是否打开，如果没有，那么打开它 [英] Excel VBA to detect if Outlook is open, if its not ,then open it

问题描述

  Const olFolderInbox = 6 
 
 Sub detectpp_plate_record1（）
 
 Dim oOutlook As Object 
 Dim oOlns As Object 
 Dim oOlInb As Object 
 Dim unRead，m As Object，att As Object 
 
'~~>获取Outlook实例
设置oOutlook = GetObject（，Outlook.application）
设置oOlns = oOutlook.GetNamespace（MAPI）
设置oOlInb = oOlns.GetDefaultFolder（olFolderInbox）
 
'~~>检查是否有任何实际的未读电子邮件
设置unRead = oOlInb.Items.Restrict（[UnRead] = True）
 
'File_Path =D：\Attach\
 
 File_Path =C：\Users\Desktop\pocket setter excel\
 
如果unRead.Count = 0然后
 MsgBoxNO未读电子邮件在收件箱中
 Else 
对于每个m在unRead 
如果m.Attachments.Count> 0然后
对于每个att在m.Attachments 
如果att.Filename像板记录*然后
 MsgBox未读电子邮件与附件可用In Inbox
 
 喜欢板记录* .xls
'~~>将附件
'下载到文件路径和文件名
'att.Filename =附件名称
 
 att.SaveAsFile File_Path& 盘记
 
'att.SaveAsFile File_Path& att.Filename 
 
'&格式（平板记录）
 
'将附件标记为已读
 m.unRead = False 
 DoEvents 
 m.Save 
 
 WorkFile = Dir （File_Path&*）
 
尽管WorkFile<> 
 
如果右（WorkFile，4）<> xlsm然后
 Workbooks.Open文件名：= File_Path& WorkFile 
 ActiveWorkbook.SaveAs文件名：= _ 
 File_Path& WorkFile& ，FileFormat：= _ 
 xlOpenXMLWorkbookMacroEnabled，CreateBackup：= False 
 ActiveWorkbook.Close 
 Kill File_Path& WorkFile 
 End If 
 
 WorkFile = Dir（）
循环
 
退出子
结束如果
下一个att 
结束如果
下一步m 
结束If 
 End Sub 
  

问题：只有当Outlook打开时，才能执行此操作。

因此，我必须单独打开Outlook。

我的要求是使用Excel VBA代码来检测Outlook是否打开，如果不是，则应该打开。

--------------------- UDATE ------------ -----------

我将上述代码与以下代码相结合。

  #Const LateBind = True 
 
 Const olMinimized As Long = 1 
 Const olMaximized As Long = 2 
 Const olFolderInbox As Long = 6 
 
 Sub detectpp_plate_record（）
 MyMacroThatUse Outlook 
 detectpp_plate_record1 
 End Sub 
 
 #If LateBind然后
 
公共功能OutlookApp（_ 
可选WindowState As Long = olMinimized，_ 
可选ReleaseIt As Boolean = False _ 
）As Object 
静态oOutlook As Object 
 #Else 
公共函数OutlookApp（_ 
可选WindowState As Outlook.OlWindowState = olMinimized，_ 
可选ReleaseIt作为布尔_ 
）作为Outlook.Application 
静态oOutlook作为Outlook.Application 
 #End如果
错误GoTo ErrHandler 
 
选择案例True 
案例oOutlook不是，Len（oOutlook.name）= 0 
设置oOutlook = GetObject（，Outlook.Application）
如果oOutlook.Explorers。 Count = 0然后
 InitOutlook：
'打开收件箱以防止出现安全提示错误
 oOutlook.Session.GetDefaultFolder（olFolderInbox）.Display 
 oOutlook.ActiveExplorer.Window State = WindowState 
 End If 
 Case ReleaseIt 
设置oOutlook = Nothing 
结束选择
设置OutlookApp = oOutlook 
 
 ExitProc：
退出功能
 ErrHandler：
选择案例Err.Number 
案例-2147352567 
'用户取消安装程序，静默退出
设置oOutlook =没有
案例429 ，462 
设置oOutlook = GetOutlookApp（）
如果oOutlook不是，然后
 Err.Raise 429OutlookApp，Outlook应用程序似乎没有安装。 
 Else 
简历InitOutlook 
结束如果
 Case Else 
 MsgBoxError&错误编号& ：& Err.Description，vbCritical，意外的错误
结束选择
恢复ExitProc 
恢复
结束功能
 
 #If LateBind然后
私人函数GetOutlookApp（）作为对象
 #Else 
私有函数GetOutlookApp（）作为Outlook.Application 
 #End如果
错误GoTo ErrHandler 
 
设置GetOutlookApp = CreateObject（Outlook.Application）
 
 ExitProc：
退出函数
 ErrHandler：
选择案例Err.Number 
案例Else 
 '不要提出任何错误
设置GetOutlookApp =没有
结束选择
恢复ExitProc 
恢复
结束函数
 
 Sub MyMacroThatUseOutlook（）
 Dim OutApp作为对象
设置OutApp = OutlookApp（）
'根据需要自动执行OutApp 
 End Sub 
  

现在，如果Outlook打开，代码将搜索指定的未读电子邮件。

如果Outlook关闭，它会打开它，但是rwards有一个错误

运行时错误429：

ActiveX组件不能创建对象。

因此，我再次点击代码的按钮搜索指定的电子邮件。

我如何摆脱的错误，并一次性执行此操作？

解决方案

将其添加到您的代码中： p>

  Dim oOutlook As object 
 
 On Error Resume Next 
 Set oOutlook = GetObject（，Outlook .Application）
错误Goto 0 
 
如果oOutlook不是，然后
设置oOutlook = CreateObject（Outlook.Application）
如果
结束我试过并测试了它， 

它有效。

I have written code to download an attachment to a specified folder.

Const olFolderInbox = 6

Sub detectpp_plate_record1()

Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object

'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")

' File_Path = "D:\Attach\"

File_Path = "C:\Users\Desktop\pocket setter excel\"

If unRead.Count = 0 Then
    MsgBox "NO Unread Email In Inbox"
Else
    For Each m In unRead
        If m.Attachments.Count > 0 Then
            For Each att In m.Attachments
                If att.Filename Like "plate record*" Then
                    MsgBox "Unread Email with attachment available In Inbox"

                    'Like "plate record*.xls"
                    '~~> Download the attachment
                    ' to the file path and file name
                    'att.Filename = name of attachement

                    att.SaveAsFile File_Path & "plate record"

                    'att.SaveAsFile File_Path & att.Filename

                    '& Format(plate record)

                    ' mark attachment as read               
                    m.unRead = False
                    DoEvents
                    m.Save

                    WorkFile = Dir(File_Path & "*")

                    Do While WorkFile <> ""

                       If Right(WorkFile, 4) <> "xlsm" Then
                          Workbooks.Open Filename:=File_Path & WorkFile
                          ActiveWorkbook.SaveAs Filename:= _
                            File_Path & WorkFile & "", FileFormat:= _
                            xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                          ActiveWorkbook.Close
                          Kill File_Path & WorkFile
                        End If

                        WorkFile = Dir()
                    Loop

                    Exit Sub
                End If
            Next att
        End If
    Next m
End If
End Sub

The problem : This can be executed only when Outlook is open.

Therefore I have to separately open Outlook.

My requirement is to use Excel VBA code to detect if Outlook is open, if it is not, then it should be opened.

---------------------UDATE-----------------------

I combined the above code with the following code.

#Const LateBind = True

Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6

Sub detectpp_plate_record()
    MyMacroThatUseOutlook
    detectpp_plate_record1
End Sub

#If LateBind Then

Public Function OutlookApp( _
    Optional WindowState As Long = olMinimized, _
    Optional ReleaseIt As Boolean = False _
    ) As Object
    Static oOutlook As Object
#Else
Public Function OutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
    Static oOutlook As Outlook.Application
#End If
On Error GoTo ErrHandler

    Select Case True
        Case oOutlook Is Nothing, Len(oOutlook.name) = 0
            Set oOutlook = GetObject(, "Outlook.Application")
            If oOutlook.Explorers.Count = 0 Then
InitOutlook:
                'Open inbox to prevent errors with security prompts
                oOutlook.Session.GetDefaultFolder(olFolderInbox).Display
                oOutlook.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set oOutlook = Nothing
    End Select
    Set OutlookApp = oOutlook

ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set oOutlook = Nothing
        Case 429, 462
            Set oOutlook = GetOutlookApp()
            If oOutlook Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler

    Set GetOutlookApp = CreateObject("Outlook.Application")

ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            'Do not raise any errors
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function

Sub MyMacroThatUseOutlook()
    Dim OutApp  As Object
    Set OutApp = OutlookApp()
    'Automate OutApp as desired
End Sub

Now, if Outlook is open the code searches for the specified unread email.

If Outlook is closed, it opens it, but afterwards there is an error

Run time error 429:

ActiveX component cant create object.

Therefore once again I have to click on button for the code to search for the specified emails.

How do I get rid of this error and perform this in one go?

解决方案

Add this to your code:

Dim oOutlook As object

    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    On Error Goto 0 

    If oOutlook Is Nothing Then
        Set oOutlook = CreateObject("Outlook.Application")
    End If

I tried and tested it . It works.

这篇关于Excel VBA检测Outlook是否打开，如果没有，那么打开它的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！