Я не из VBA и взял на себя чужую работу. По какой-то причине сегодня, когда макрос был запущен для открытия «формы», появлялась следующая ошибка - Me.txtOutlookEntryID = mailObject.EntryID
Public Sub loadMessage()
'Error Handler
On Error GoTo errorhandler
'Declare Variables
Dim rs As ADODB.Recordset
Dim catRS As ADODB.Recordset
Dim trailRS As ADODB.Recordset
Dim attachmentRS As ADODB.Recordset
Dim foundCount As Integer
Dim mailObject As Object
Dim folderLocation As String
'Enable the form
Call enableDisableForm(True)
'First try to connect to database
If databaseConnect = False Then Err.Raise 6000 + vbObjectError, "LQST_Form:loadMessage()", "Unable to connect to database."
'***********************************************************************************************
'***********************************************************************************************
'***********************************************************************************************
'Either
' - Item is loaded in its own window
' - Item is selected in a list
Select Case Outlook.ActiveWindow.Class
Case olExplorer
Set mailObject = Outlook.ActiveExplorer.Selection.Item(1) 'Selected in the main Outlook Application
Case olInspector
Set mailObject = Outlook.ActiveInspector.CurrentItem 'Open in an explorer
End Select
'Check the type of object you are trying to open this form with
Select Case TypeName(mailObject)
Case "MailItem"
'This item is ok
Case Else
Err.Raise 6001 + vbObjectError, "LQST_Form:loadMessage()", "Sorry no LQST data available for this type of Outlook object."
End Select
'***********************************************************************************************
'***********************************************************************************************
'***********************************************************************************************
'Ignored this as we are now going to allow the item to be loaded from any mailbox
'If checkOpenMsgInLQS(mailObject) = False Then
'err.Raise 6002 + vbObjectError, "LQST_Form:loadMessage()", "Message is not located in any of the LQS Mailboxes."
'End If
'Now connect and retrieve all the data
Call recordsetStateClose(rs, True)
Dim retrieveMsgSQL As String
Dim formattedSubject As String
formattedSubject = formatSubject(mailObject.subject)
'First try without changing the time
Select Case conType
Case "Access"
retrieveMsgSQL = "SELECT [LQS Tracking Emails].*, [LQS Users].[Full Name] FROM [LQS Tracking Emails] INNER JOIN [LQS Users] ON [LQS Tracking Emails].UserID = [LQS Users].UserID WHERE [CmpSubject] " & formattedSubject & " and [ReceivedDate] = #" & Format(mailObject.ReceivedTime, "mm/dd/yyyy hh:mm:ss") & "#"
Case Else 'If contype = SQL or other
retrieveMsgSQL = "SELECT [LQS Tracking Emails].*, [LQS Users].[Full Name] FROM [LQS Tracking Emails] INNER JOIN [LQS Users] ON [LQS Tracking Emails].UserID = [LQS Users].UserID WHERE [CmpSubject] " & formattedSubject & " and [ReceivedDate] = CONVERT(DATETIME, '" & mailObject.ReceivedTime & "', 103)"
End Select
'Open the recordset
rs.Open retrieveMsgSQL, Con, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic
If rs.EOF = True Then
rs.Close
Select Case conType
Case "Access"
retrieveMsgSQL = "SELECT [LQS Tracking Emails].*, [LQS Users].[Full Name] FROM [LQS Tracking Emails] INNER JOIN [LQS Users] ON [LQS Tracking Emails].UserID = [LQS Users].UserID WHERE [CmpSubject] " & formattedSubject & " and [ReceivedDate] = #" & Format(TimeZone.convertToGMT_With_DS(mailObject.ReceivedTime), "mm/dd/yyyy hh:mm:ss") & "#"
Case Else 'If contype = SQL or other
retrieveMsgSQL = "SELECT [LQS Tracking Emails].*, [LQS Users].[Full Name] FROM [LQS Tracking Emails] INNER JOIN [LQS Users] ON [LQS Tracking Emails].UserID = [LQS Users].UserID WHERE [CmpSubject] " & formattedSubject & " and [ReceivedDate] = CONVERT(DATETIME, '" & TimeZone.convertToGMT_With_DS(mailObject.ReceivedTime) & "', 103)"
End Select
rs.Open retrieveMsgSQL, Con, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic
End If
folderLocation = getFolderOfCurrentMailObject(mailObject)
'If EOF = false then record has been found
If rs.EOF = False Then
'Entry ID is used so that we can check whether email is in focus - affected if they move the email
'Здесь ошибка показывает Me.txtOutlookEntryID = mailObject.EntryID
'Загрузить все данные, затем ошибка, если найдено более 1 записи
Если не IsNull (rs.Fields ("MsgID")), то Me.txtMessageID = rs.Fields ("MsgID")
Если не IsNull (rs.Fields ("CmpSubject")), то Me.txtSubject = rs.Fields ("CmpSubject")
Если не IsNull (rs.Fields ("AddedDB")), то Me.txtAddedDB = rs.Fields ("AddedDB")
«Если идентификатор трейла не нулевой, тогда делайте другие унаследования трейла
Если не IsNull (rs.Fields ("Trail ID")), то
Me.lblCurrentTrailID.Caption = rs.Fields ("Идентификатор следа")
Me.txtTrailID = rs.Fields ("Trail ID")
'Count the amount in the trail
Call recordsetStateClose(trailRS, True)
trailRS.Open "SELECT Count([LQS Tracking Emails].MsgID) AS CountOfMsgID FROM [LQS Tracking Emails] GROUP BY [Trail ID] HAVING ([Trail ID]=" & txtTrailID.Text & ")", Con, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic
If trailRS.EOF = False Then Me.txtTrailCount.Text = trailRS.Fields("CountOfMsgID") Else Me.txtTrailCount.Text = 0
Call recordsetStateClose(trailRS, False)
'Get the initial Trail Subject
Call recordsetStateClose(trailRS, True)
trailRS.Open "SELECT [LQS Tracking Emails].CmpSubject FROM [LQS Tracking Emails] WHERE [LQS Tracking Emails].[Trail ID] = " & txtTrailID.Text & " AND [LQS Tracking Emails].[ReceivedDate] = (SELECT Min([LQS Tracking Emails].ReceivedDate) AS MinOfReceivedDate FROM [LQS Tracking Emails] WHERE ((([LQS Tracking Emails].[Trail ID])=" & txtTrailID.Text & ")))", Con, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic
If Not IsNull(trailRS.Fields("CmpSubject")) Then Me.txtInitialTrailSubject.Text = trailRS.Fields("CmpSubject") Else Me.txtInitialTrailSubject.Text = ""
Call recordsetStateClose(trailRS, False)
Else
'if no trail id is found then the reason is multiple trails were found - this should have stopped with V3
Me.lblCurrentTrailID.Caption = "Multiple Trails Found"
Me.txtTrailID = "Multiple Trails Found"
End If
If Not IsNull(rs.Fields("TrailIDDate")) Then Me.txtTrailDate = rs.Fields("TrailIDDate")
If folderLocation <> "" Then
Me.txtLastLocation = folderLocation
Else
If Not IsNull(rs.Fields("Location")) Then Me.txtLastLocation = rs.Fields("Location")
End If
If Not IsNull(rs.Fields("Full Name")) Then Me.txtUser = rs.Fields("Full Name")
If Not IsNull(rs.Fields("Comments")) Then Me.txtNotes = rs.Fields("Comments")
If Not IsNull(rs.Fields("TypeID")) Then Me.lblCurrentCategory.Caption = rs.Fields("TypeID")
If Not IsNull(rs.Fields("HotTopicID")) Then Me.lblCurrentHotTopic.Caption = rs.Fields("HotTopicID")
'Refresh the attachmentsList
Call refreshLQSTFormAttachmentsList(Me)
'Database disconnected in previous methods so have to reconnect again for recordset
If databaseConnect = False Then Err.Raise 6000 + vbObjectError, "LQST_Form:loadMessage()", "Unable to connect to database."
'open recordset
Call recordsetStateClose(catRS, True)
'Get all LQS Types
catRS.Open "Select * from [LQS Type] ORDER BY TypeName ASC", Con, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic
'Populate Category List
Dim selectedCategory As String, selectedHotTopic As String
If catRS.recordcount <> 0 Then
Do While Not catRS.EOF
lstCategories.AddItem catRS.Fields("TypeName") ', catRS.Fields("CategoryID")
If catRS.Fields("TypeID") = rs.Fields("TypeID") Then
selectedCategory = catRS.Fields("Typename")
End If
catRS.MoveNext
Loop
End If
Call recordsetStateClose(catRS, False)
Call recordsetStateClose(catRS, True)
catRS.Open "Select * from [LQS Hot Topic] ORDER BY HotTopicName ASC", Con, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic
'Populate Category List
If catRS.recordcount <> 0 Then
Do While Not catRS.EOF
lstHotTopic.AddItem catRS.Fields("HotTopicName") ', catRS.Fields("CategoryID")
If catRS.Fields("HotTopicID") = rs.Fields("HotTopicID") Then
selectedHotTopic = catRS.Fields("HotTopicName")
End If
catRS.MoveNext
Loop
End If
Call recordsetStateClose(catRS, False)
'More than 1 record for email found - 1st one loaded
If rs.recordcount > 1 Then
Call recordsetStateClose(rs, False)
Set mailObject = Nothing
Err.Raise 6003 + vbObjectError, "LQST_Form:loadMessage()", "More than 1 record for the email found in the database - 1st one loaded."
End If
Else
Call recordsetStateClose(rs, False)
Set mailObject = Nothing
Err.Raise 6004 + vbObjectError, "LQST_Form:loadMessage()", "Email not found in the database."
End If
'Set the location of the file to be the file it currently is in
Con.Execute "UPDATE [LQS Tracking Emails] SET [Location] = '" & folderLocation & "' WHERE [MsgID] = " & rs.Fields("MsgID")
'These are updated at the end as there are events on the text boxes for change of text
'These functions close the database and so affects the code above
lstHotTopic.value = selectedHotTopic
lstCategories.value = selectedCategory
Call recordsetStateClose(rs, False)
Set mailObject = Nothing
Exit Sub
errorhandler:
thrownErrNum = Err.Number
thrownErrSource = Err.Source
thrownErrDesc = Err.Description
Call enableDisableForm(False)
Call recordsetStateClose(rs, False)
Call recordsetStateClose(catRS, False)
Call recordsetStateClose(trailRS, False)
Set mailObject = Nothing
'Throw error, clearing the variables
Err.Raise thrownErrNum, thrownErrSource, thrownErrDesc
End Sub
Пожалуйста, дайте мне знать, если вам нужна дополнительная информация