问题描述
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是否打开,如果没有,那么打开它的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持!