runtime error 91 object variable or With block variable not set vb6 in test machine however working properly in development machine - dll

I have activex dll which has code for message queue, read and write from remote as well as local machine.
i did some changes for reading messages from remote queue and tested that dll with sample form application.
which works fine
however when i copied this dll to my test machine (in actual application)
i am facing "runtime error 91 object variable or With block variable not set"
error
if i revert my changes its working fine
code after changes
Private Function RetrieveMessage(ByVal MQReceive As msmq.MSMQQueue, _
MQTransaction As msmq.MSMQTransaction, _
ByVal Wait As Boolean, MessageLabel As String, MessageBody As String) As Boolean
'Dim MQReceive As MSMQ.MSMQQueue
Dim MQMsgRec As MSMQMessage
Dim MQDispenser As msmq.MSMQCoordinatedTransactionDispenser
On Error GoTo ErrorHandler
RetrieveMessage = False
If Not m_bQueueExists Then
Err.Raise vbObjectError + 1, "MicrosoftMQImpl", "Queue " & m_sQueueName & _
" does not exist"
Else
Set MQDispenser = New msmq.MSMQCoordinatedTransactionDispenser
'Begin Transaction
Set MQTransaction = MQDispenser.BeginTransaction
Dim bMessageFound As Boolean
bMessageFound = False
Set MQMsgRec = MQReceive.Receive(ReceiveTimeout:=IIf(Wait = True, DISPATCH_MESSAGE_INTERVAL, 0))
'Set MQMsgRec = MQReceive.Receive(Transaction:=MQTransaction, _
' ReceiveTimeout:=IIf(Wait = True, DISPATCH_MESSAGE_INTERVAL, 0))
If MQMsgRec Is Nothing Then
bMessageFound = False
Else
bMessageFound = True
MessageBody = CStr(MQMsgRec.Body)
MessageLabel = CStr(MQMsgRec.Label)
End If
Set MQDispenser = Nothing
Set MQMsgRec = Nothing
RetrieveMessage = bMessageFound
MQTransaction.Commit
Set MQTransaction = Nothing
End If
Exit Function
ErrorHandler:
If Not (MQTransaction Is Nothing) Then
MQTransaction.Abort
Set MQTransaction = Nothing
End If
LogNTEvent "PHLMessaging:MicrosoftMQImpl:RetrieveMessage", Err.Description, eNTLog_Error
Err.Raise Err.Number, Err.Source, Err.Description
End Function
code before changes
Private Function RetrieveMessage(ByVal MQReceive As msmq.MSMQQueue, _
MQTransaction As msmq.MSMQTransaction, _
ByVal Wait As Boolean, MessageLabel As String, MessageBody As String) As Boolean
'Dim MQReceive As MSMQ.MSMQQueue
Dim MQMsgRec As MSMQMessage
Dim MQDispenser As msmq.MSMQTransactionDispenser
On Error GoTo ErrorHandler
RetrieveMessage = False
If Not m_bQueueExists Then
Err.Raise vbObjectError + 1, "MicrosoftMQImpl", "Queue " & m_sQueueName & _
" does not exist"
Else
Set MQDispenser = New msmq.MSMQTransactionDispenser
'Begin Transaction
Set MQTransaction = MQDispenser.BeginTransaction
Dim bMessageFound As Boolean
bMessageFound = False
Set MQMsgRec = MQReceive.Receive(Transaction:=MQTransaction, _
ReceiveTimeout:=IIf(Wait = True, DISPATCH_MESSAGE_INTERVAL, 0))
If MQMsgRec Is Nothing Then
bMessageFound = False
Else
bMessageFound = True
MessageBody = CStr(MQMsgRec.Body)
MessageLabel = CStr(MQMsgRec.Label)
End If
Set MQDispenser = Nothing
Set MQMsgRec = Nothing
RetrieveMessage = bMessageFound
End If
Exit Function
ErrorHandler:
If Not (MQTransaction Is Nothing) Then
MQTransaction.Abort
Set MQTransaction = Nothing
End If
LogNTEvent "PHLMessaging:MicrosoftMQImpl:RetrieveMessage", Err.Description, eNTLog_Error
Err.Raise Err.Number, Err.Source, Err.Description
End Function
Thanks in advance


i somehow managed to resolve this error
just commented following code in changes
MQTransaction.Commit
Set MQTransaction = Nothing
still dont know why :-|

Related

How to auto-backup Access Database

I want to autoback up my access database with the below code and it didn't work for me. I got an error "cannot find the input table or query "WinAutoBackup" Please view the picture. Also, did I use CurrentProject correctly?
[Function fMakeBackup() As Boolean
Dim Source As String
Dim Target As String
Dim retval As Integer
On Error GoTo sysBackup_Err
Source = CurrentDb.name
Target = "CurrentProject.path\backups\"
Target = Target & Format(Now, "yyyymmdd-hhnn") & ".accdb"
If DateDiff("d", DLookup("\[BackupDate\]", "WinAutoBackup", "\[BckID\]
=1"), Date) = 3 Then
retval = 0
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE WinAutoBackup SET WinAutoBackup.BackupDate =
Date();"
DoCmd.SetWarnings True
MsgBox "Backup successfull. Next auto backup in 3 days"
Else
Exit Function
End If
sysBackup_Exit:
Exit Function
sysBackup_Err:
MsgBox Err.Description, , "sysBackup()"
Resume sysBackup_Exit
End Function][1]

Start with including:
Option Explicit
at the top of the module.
Then try with:
Function fMakeBackup() As Boolean
Dim objFSO As Object
Dim Source As String
Dim Target As String
Dim retval As Integer
' Disable error handling during development.
' On Error GoTo sysBackup_Err
Source = CurrentDb.Name
' Adjust if if backup folder is not \backups\.
Target = CurrentProject.Path & "\backups\"
Target = Target & Format(Now, "yyyymmdd-hhnn") & ".accdb"
' To run every time, use this line in plade of If DateDiff ...:
' If True Then
If DateDiff("d", DLookup("[BackupDate]", "[WinAutoBackup]", "[BckID] = 1"), Date) >= 3 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE WinAutoBackup SET WinAutoBackup.BackupDate = Date() WHERE [BckID] = 1;"
DoCmd.SetWarnings True
MsgBox "Backup successful. Next auto backup in 3 days."
End If
sysBackup_Exit:
Exit Function
sysBackup_Err:
MsgBox Err.Description, , "sysBackup()"
Resume sysBackup_Exit
End Function

Capture Opened Workbook in New Instance of Excel

I have a number of macros where I want it run some code, then prompt the user to export an Excel workbook from another program, then run more code once the export has been opened. The tricky part is that some programs export to a new instance of Excel, while other programs export to the current instance.
The current workflow is (code at bottom):
Call the central 'Capture' Module with the name of the export (some
programs export 'Book[x]' some do 'workbook[x]', etc.) and the
procedure you want to run once the export is found.
Capture Module gets a list of all existing workbook names from all
Excel instances and saves as a Module-level string.
Capture Module uses Application.OnTime so that every 3 seconds, it
scans the list of all workbooks across all Excel instances.
If it finds a workbook that is not in the previously saved list of
all existing workbook names, and that contains the name of the
export, it stores that workbook as a public module level variable,
and runs the saved procedure from Step 1, which can the reference
the store workbook.
This works very well in all circumstances, EXCEPT for one. If I already have Book1.xlsx open in my current instance of Excel, and the 3rd party program exports Book1.xlsx to a NEW instance of Excel, the program doesn't recognize this as the export, since Book1.xlsx is in the existing workbook names string array already.
My solution is to find some way of uniquely identifying each workbook that's better than 'Name' or 'Path'. I tried saving each workbook name in the existing workbook names string as [application.hwnd]![workbook name] but this was an unstable fix and frequently broke (I don't really understand how hwnd works so I can't say why).
Any ideas? Thanks!
Sample Procedures That Use MCaptureExport
Public Sub GrabFXAllExport()
Const sSOURCE As String = "GrabFXAllExport"
On Error GoTo ErrorHandler
If Not TAAA.MCaptureExport.bCaptureExport("FXALL", "TAAA.FXAllEmail.ProcessFXAllExport") Then Err.Raise glHANDLED_ERROR
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
Public Sub ProcessFXAllExport()
Const sSOURCE As String = "ProcessFXAllExport"
On Error GoTo ErrorHandler
If MCaptureExport.mwbCaptured Is Nothing Then
MsgBox "Exported Workbook Not Found. Please try again.", vbCritical, gsAPP_NAME
GoTo ErrorExit
End If
Dim wsSourceSheet As Worksheet
Set wsSourceSheet = MCaptureExport.mwbCaptured.Worksheets(1)
Set MCaptureExport.mwbCaptured = Nothing
[I now have the export and can work with it as a I please]
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
MCaptureExport Module
Option Explicit
Option Base 1
' Description: This module contains the central error
' handler and related constant declarations.
Private Const msMODULE As String = "MCaptureExport"
Private sExistingWorkbookList() As String
Public mwbCaptured As Workbook
Public msCaptureType As String
Private sReturnProcedure As String
Private bListening As Boolean
Public Function bCaptureExport(sCaptureType As String, sRunAfterCapture As String) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureExport()"
On Error GoTo ErrorHandler
bReturn = True
If Not bWorkbookNamesAsArray(sExistingWorkbookList, True, False) Then Err.Raise glHANDLED_ERROR
sReturnProcedure = sRunAfterCapture
bListening = True
msCaptureType = sCaptureType
TAAA.MCaptureExport.WaitForCapture sCaptureTypeToNameContains(msCaptureType)
MsgBox "Waiting for " & msCaptureType & " Export", vbInformation, gsAPP_NAME
ErrorExit:
bCaptureExport = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Sub WaitForCapture(sNameContains As String)
Const sSOURCE As String = "WaitForCapture"
On Error GoTo ErrorHandler
Dim wbCaptureCheck As Workbook
If Not bCaptureCheck(sNameContains, wbCaptureCheck) Then Err.Raise glHANDLED_ERROR
If wbCaptureCheck Is Nothing Then
If bListening Then _
Application.OnTime Now + TimeSerial(0, 0, 3), "'TAAA.MCaptureExport.WaitForCapture " & Chr(34) & sNameContains & Chr(34) & "'"
Else
Dim bSameApp As Boolean
If Not bWorkbooksInSameApp(ThisWorkbook, wbCaptureCheck, bSameApp) Then Err.Raise glHANDLED_ERROR
If Not bSameApp Then
Dim sTempFilePath As String
sTempFilePath = ThisWorkbook.Path & "\temp_" & Format(Now, "mmddyyhhmmss") & ".xls"
wbCaptureCheck.SaveCopyAs sTempFilePath
wbCaptureCheck.Close SaveChanges:=False
Set wbCaptureCheck = Application.Workbooks.Open(sTempFilePath)
End If
Set mwbCaptured = wbCaptureCheck
bListening = False
Application.Run sReturnProcedure
End If
ErrorExit:
Exit Sub
ErrorHandler:
If bCentralErrorHandler(msMODULE, sSOURCE, , True) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Sub
Private Function sCaptureTypeToNameContains(sCaptureType As String) As String
sCaptureTypeToNameContains = "*"
On Error Resume Next
Select Case UCase(sCaptureType)
Case "SOTER": sCaptureTypeToNameContains = "workbook"
Case "THOR": sCaptureTypeToNameContains = "Book"
Case "FXALL": sCaptureTypeToNameContains = "search_results_export"
End Select
End Function
Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureCheck()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
If wb.Name Like "*" & sNameContains & "*" _
And Not bIsInArray(wb.Name, sExistingWorkbookList) Then
Set wbResult = wb
GoTo ErrorExit
End If
Next
Next
ErrorExit:
bCaptureCheck = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Utility Functions Used by MCaptureExport
Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbookNamesAsArray()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
Dim ResultArray() As String
Dim Ndx As Integer, wbCount As Integer
If bAllInstances Then
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
Else
ReDim xlApps(0)
Set xlApps(0) = Application
End If
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
wbCount = wbCount + 1
Next
Next
ReDim ResultArray(1 To wbCount)
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
Ndx = Ndx + 1
ResultArray(Ndx) = wb.Name
Next
Next
sResult = ResultArray()
ErrorExit:
bWorkbookNamesAsArray = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Public Function bGetAllExcelInstances(xlApps() As Application) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bGetAllExcelInstances()"
On Error GoTo ErrorHandler
bReturn = True
Dim n As Long
Dim hWndMain As LongPtr
Dim app As Application
' Cater for 100 potential Excel instances, clearly could be better
ReDim xlApps(1 To 100)
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWndMain <> 0
If Not bGetExcelObjectFromHwnd(hWndMain, app) Then Err.Raise glHANDLED_ERROR
If Not (app Is Nothing) Then
If n = 0 Then
n = n + 1
Set xlApps(n) = app
ElseIf bCheckHwnds(xlApps, app.Hwnd) Then
n = n + 1
Set xlApps(n) = app
End If
End If
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
If n Then
ReDim Preserve xlApps(1 To n)
'GetAllExcelInstances = n
Else
Erase xlApps
End If
ErrorExit:
bGetAllExcelInstances = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Function bCheckHwnds(xlApps() As Application, Hwnd As LongPtr) As Boolean
On Error Resume Next
Dim i As Integer
For i = LBound(xlApps) To UBound(xlApps)
If Not xlApps(i) Is Nothing Then
If xlApps(i).Hwnd = Hwnd Then
bCheckHwnds = False
Exit Function
End If
End If
Next i
bCheckHwnds = True
End Function
Public Function bWorkbooksInSameApp(wb1 As Workbook, wb2 As Workbook, bSameApp As Boolean) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbooksInSameApp()"
On Error GoTo ErrorHandler
bReturn = True
bSameApp = wb1.Application.Hwnd = wb2.Application.Hwnd
ErrorExit:
bWorkbooksInSameApp = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Private Function bGetExcelObjectFromHwnd(ByVal hWndMain As LongPtr, aAppResult As Application) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bGetExcelObjectFromHwnd()"
On Error GoTo ErrorHandler
bReturn = True
Dim hWndDesk As LongPtr
Dim Hwnd As LongPtr
Dim strText As String
Dim lngRet As Long
Dim iid As UUID
Dim obj As Object
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
Hwnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Do While Hwnd <> 0
strText = String$(100, Chr$(0))
lngRet = CLng(GetClassName(Hwnd, strText, 100))
If Left$(strText, lngRet) = "EXCEL7" Then
Call IIDFromString(StrPtr(IID_IDispatch), iid)
If AccessibleObjectFromWindow(Hwnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Set aAppResult = obj.Application
GoTo ErrorExit
End If
End If
Hwnd = FindWindowEx(hWndDesk, Hwnd, vbNullString, vbNullString)
Loop
End If
ErrorExit:
bGetExcelObjectFromHwnd = bReturn
Exit Function
ErrorHandler:
MsgBox Err.Number
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function

I have a potential solution. However I want to leave the question open. This is a fairly complicated problem and I bet there are more elegant solutions than what I'm proposing.
So I updated the format of sExistingWorkbookList to [Application.hWnd]![Workbook.name]. I had tried this before but I think it's working this time.
Thoughts?
Updated Version of bWorkbookNamesAsArray
Added wb.Application.Hwnd & "!" & to ResultArray(Ndx) = wb.name
Public Function bWorkbookNamesAsArray(sResult() As String, Optional bAllInstances As Boolean = True) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bWorkbookNamesAsArray()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook
Dim xlApps() As Application
Dim ResultArray() As String
Dim Ndx As Integer, wbCount As Integer
If bAllInstances Then
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
Else
ReDim xlApps(0)
Set xlApps(0) = Application
End If
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
wbCount = wbCount + 1
Next
Next
ReDim ResultArray(1 To wbCount)
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
Ndx = Ndx + 1
ResultArray(Ndx) = wb.Application.Hwnd & "!" & wb.Name
Next
Next
sResult = ResultArray()
ErrorExit:
bWorkbookNamesAsArray = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
New Utility Function
Public Function bGetWorkbookFromHwndAndName(ByVal sWorkbookReference As String, ByRef wbResult As Workbook)
Dim bReturn As Boolean
Const sSOURCE As String = "bGetWorkbookFromHwndAndName()"
On Error GoTo ErrorHandler
bReturn = True
Dim xlApp As Application
If Not bGetExcelObjectFromHwnd(CLng(Split(sWorkbookReference, "!")(0)), xlApp) Then Err.Raise glHANDLED_ERROR
Set wbResult = xlApp.Workbooks(Split(sWorkbookReference, "!")(1))
ErrorExit:
bGetWorkbookFromHwndAndName = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function
Updated MCaptureExport.bCaptureCheck()
Private Function bCaptureCheck(sNameContains As String, wbResult As Workbook) As Boolean
Dim bReturn As Boolean
Const sSOURCE As String = "bCaptureCheck()"
On Error GoTo ErrorHandler
bReturn = True
Dim i As Long, wb As Workbook, sFullWorkbookReference As String
Dim xlApps() As Application
If Not bGetAllExcelInstances(xlApps) Then Err.Raise glHANDLED_ERROR
For i = LBound(xlApps) To UBound(xlApps)
For Each wb In xlApps(i).Workbooks
sFullWorkbookReference = wb.Application.Hwnd & "!" & wb.Name
If wb.Name Like "*" & sNameContains & "*" _
And Not bIsInArray(sFullWorkbookReference, sExistingWorkbookList) Then
If Not bGetWorkbookFromHwndAndName(sFullWorkbookReference, wbResult) Then Err.Raise glHANDLED_ERROR
GoTo ErrorExit
End If
Next
Next
ErrorExit:
bCaptureCheck = bReturn
Exit Function
ErrorHandler:
bReturn = False
If bCentralErrorHandler(msMODULE, sSOURCE) Then
Stop
Resume
Else
Resume ErrorExit
End If
End Function

Excel VBA to detect if Outlook is open, if its not ,then open it

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.

Something like this:-
Set oOutlook = GetObject(, "Outlook.application")
If oOutlook is nothing Then
'outlook is not running so start it
set oOutlook = New Outlook.Application
Else
' outlook is running
End If

VBA macros - export CSV file format and extension don't match

I'm using this code to export Outlook data (emails) to CSV file:
Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strFilename As String
'strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
strFilename = "C:...\...\Emails.csv"
If strFilename <> "" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
'Write messages to spreadsheet
For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = olkMsg.SenderName
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
But when I open the downloaded file, Excel says the file format and extension don't match.
What could cause this issue?

Change your two lines from:
excWkb.SaveAs strFilename
excWkb.Close
to:
excWkb.SaveAs Filename:=strFilename, FileFormat:=xlCSV, CreateBackup:=False
excWkb.Close SaveChanges:=False

Last modification date of open workbook

Vba newbie. Need a function to output the last modification date of an open workbook. Here is what I have so far but I am getting a message that my formula contains an error when I invoke the function:
Function LastWBModDate(wbname)
ActivateWB (wbname)
LastWBModDate = Format(FileDateTime(ActiveWorkbook.FullName), "m/d/yy h:n ampm")
End Function
Public Function ActivateWB(wbname As String)
If IsWBOpen(wbname) Then
Workbooks(wbname).Activate
Else
MsgBox "Workbook : " & wbname & " is not open " & vbNewLine
End If
End Function
Public Function IsWBOpen(wbname As String) As Boolean
On Error Resume Next
If Workbooks(wbname) Is Nothing Then
IsWBOpen = False
Else
IsWBOpen = True
End If
End Function
Thanks!

Function LastWBModDate(wbname As String)
Dim rv, wb As Workbook
rv = "workbook?" 'default return value
On Error Resume Next
Set wb = Workbooks(wbname)
On Error GoTo 0
If Not wb Is Nothing Then
rv = Format(FileDateTime(wb.FullName), "m/d/yy h:n ampm")
End If
LastWBModDate = rv
End Function

Try below code :
You may also refer this link
Put below code on ThisWorkbook code section
Private Sub Workbook_Open()
LastWBModDate
End Sub
Put this code in any Standard Module
Function LastWBModDate() As String
Dim FSO As Object
Dim File As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set File = FSO.GetFile(ThisWorkbook.FullName)
LastWBModDate = Format(File.DateLastModified, "m/d/yy h:n ampm")
Msgbox LastWBModDate
Set FSO = Nothing
End Function