|
Question : Debugging/Modifying VB Code for Macro in Excel
|
|
Hi,
I have the following code that was provided by will_scarlet7 from the Outlook Experts Exchange page.
It's a Macro using Outlook Redemption that when run brings up a dialog box that allows the user to choose a particular mailbox from Outlook and then proceeds to read the contents of that mailbox transferring the fields specified in the Macro into an Excel spreadsheet. Now the Macro below contains basic fields, but I'll add in the exact fields from the Outlook Custom forms later.
I'd be grateful if someone could run this macro and tell me what they think - I have the following issues that I'd be grateful for advice on:
* When I run the Macro depending on the Mailbox I choose I sometimes get a VB dialog box with only the crtitcal message sign. Why does that happen - is there somethign wrong with my machine?
* Run time error 4096 - One or more of the items you synchronised do not match.To resolve the conflicts open the items and then try this operation again. How do I trap all possibel errors so that it the Macro doesn't fall over here?
Sub SaveAttachments()
Dim oOutlook As Outlook.Application
Dim mAttach As Object
Dim oNs As Outlook.Namespace
Dim oFldr As Outlook.MAPIFolder
Dim oMessage As Object
Dim oSfMsg As Redemption.SafeMailItem
Dim oAttachment As Redemption.Attachment
Dim iCtr, rCtr As Integer
Dim iAttachCnt As Integer
Dim mSubject, mAttName, mAttName1, mAttName2, mFrom, mBody As String
Dim mAttachments As String
'if user cancels Outlook Folder picker
On Error GoTo SaveErrHndlr
'Set and pick the Outlook folder to save info from
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.PickFolder
Set mAttach = CreateObject("Scripting.FileSystemObject")
Set oSfMsg = CreateObject("Redemption.SafeMailItem")
'Reset error handler to default
On Error GoTo 0
'Get first blank row num
rCtr = GetRowNum
'Scan through each mail item in the selected Outlook folder
' recording the e-mail info to
' the current worksheet
For Each oMessage In oFldr.Items
oSfMsg.Item = oMessage
If oSfMsg.Unread = True Then 'Only process unread emails
mSubject = oSfMsg 'Get e-mail subject
mFrom = oSfMsg.SenderName 'Get e-mail SendersName
mBody = oSfMsg.Body 'Get e-mail message body
mAttachments = ""
'Look for attachments in the current mail item.
With oSfMsg.Attachments
mAttName = ""
iAttachCnt = .Count
'If attachments exist in the current mail item
If iAttachCnt > 0 Then
'Do the following for each attachment in the current mail item.
For iCtr = 1 To iAttachCnt
mAttName = .Item(iCtr).Filename 'Get original file name of the attachment
mAttachments = mAttachments & " " & mAttName & vbCrLf
Next iCtr
Else 'No attachment exists in the current mail item
mAttachments = "No files attached to the e-mail."
End If
End With
'Append e-mail info
Range("A" + Trim(Str(rCtr))).Value = mFrom
Range("B" + Trim(Str(rCtr))).Value = mSubject
Range("C" + Trim(Str(rCtr))).Value = mBody
Range("D" + Trim(Str(rCtr))).Value = mAttachments
'AppendAttachmentInfo mAttachments, mSubject, mFrom, mBody
DoEvents
'Now mark email as read.
oSfMsg.Unread = False
rCtr = rCtr + 1
End If
Next oMessage
GoTo CloseSaveAttachments
'If user cancels Outlook Folder selection
SaveErrHndlr:
If Err.Description = "Object variable or With block variable not set" Then
MsgBox "Canceled by user.", vbOKOnly, "Closing"
End If
GoTo CloseSaveAttachments
'Release environment objects
CloseSaveAttachments:
Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
Set oSfMsg = Nothing
End Sub
Function GetRowNum() As Integer
Dim rowNum As Integer
Dim cellVal As String
rowNum = 1
cellVal = Range("A" + Trim(Str(rowNum))).Value
'If cell A1 is empty then assume it is a blank worksheet
' and proceede to format the first row a column headers
If cellVal = "" Then
FrmtColHdr
GetRowNum = 2
Else
'else assume that you are adding to a previously formated
'worksheet, so find the next empty row for column A
Do While cellVal <> ""
rowNum = rowNum + 1
cellVal = Range("A" + Trim(Str(rowNum))).Value
Loop
End If
End Function
Function FrmtColHdr()
'Format column widths
Columns("A:A").ColumnWidth = 10 'From
Columns("B:B").ColumnWidth = 40 'Subject
Columns("C:C").ColumnWidth = 40 'Body
Columns("D:D").ColumnWidth = 40 'Attachments
'Fill in Column Headers
Range("A1").Value = "From"
Range("B1").Value = "Subject"
Range("C1").Value = "Message Body"
Range("D1").Value = "Attachments"
End Function
Run time error 4096 - One or more of the items you synchronised do not match.To resolve the conflicts open the items and then try this operation again"
|
|
|
Answer : Debugging/Modifying VB Code for Macro in Excel
|
|
Andrew, are you still working on this today? I've posted a link to this thread in the Programming ->VB section to see if we can't get some input from the wise and learned over there.
Assuming that you have done what I suggested in my previous post (re-booted) and are still getting the "System Error &H8000FFFF (-2147418113)" error, my next thought would be that something is messed up in the excel file somehow. So my next suggestion would be to create a blank worksheet and paste in the code that you posted this morning in this thread and see if it will run from a new worksheet.
I know this may sound pointless and like why would that work, but I have a database that has had a similar problem and the only way to fix it was pretty much this.
Let me know if I should keep trying this afternoon or if you are going to put it asside til later, OK.
Sam.
|
|
|
|
|
