Link to home
Start Free TrialLog in
Avatar of Wilbat
WilbatFlag for United States of America

asked on

"Unspecified Error" saving changes to CDO.Message item

I have adapted the code below from a sample given by Glen Scales at OutlookExchange.com.  I had several errors using his code verbatim and slowly whittled it down to this.  However, I am still getting an error on the line msgobj.DataSource.Save.
The gist of the code is to check each message in the given Public Folder for attachments, save the attachments to a file system folder, remove the attachment from the message, add a small ICO file attachment back to the message and then to embed a link to the original file attachment in the message body.

Dim Rec,Rs,strURLInbox,msgobj,msgobj1,flds,objArgs,strView
cfpath = "file://./backofficestorage/domain.COM/PUBLIC FOLDERS/Cases/~Test Client" & cfpath
Set WshShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set Conn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
Conn.Provider = "ExOLEDB.DataSource"
Conn.Open cfpath
strView = "SELECT ""DAV:href"""
strView = strView & " FROM scope ('shallow traversal of """& cfpath & """') "
strview = strview & " WHERE ""DAV:isfolder"" = false and ""urn:schemas:httpmail:hasattachment"" = True and ""DAV:contentclass"" = 'urn:content-classes:message' "
rs.CursorLocation = 3 'adUseServer = 2, adUseClient = 3
rs.CursorType = 3
Rs.Open strView, Conn, 2
If Rs.RecordCount <> 0 Then
      Rs.MoveFirst
      While Not Rs.EOF
            if err.number <> 0 then
                  rs.movenext
                  err.clear
            end if
            svcdir = "C:\temp\~Test Client"
            savepath = svcdir & "\"
            if not fso.folderexists(svcdir) then
                  set fldr = fso.createfolder(svcdir)
            end if
            Set msgobj = CreateObject("CDO.Message")
            msgobj.DataSource.Open rs.fields("DAV:href").value, ,3
            attachcount = msgobj.attachments.count
            Redim attarray(attachcount)
            Redim attnarray(attachcount)
            arrcnt = 1
            For Each objAttachment In msgobj.Attachments
                  If Instr(objAttachment.FileName, ".") > 0 Then
                        attname = Left(objAttachment.FileName, InStrRev(objAttachment.FileName,".") - 1)
                        attext = Mid(objAttachment.FileName, InStrRev(objAttachment.FileName,".") + 1)
                  Else
                        attname = objAttachment.FileName
                        attext = ""
                  End If                              
                  rtime = Replace(msgobj.ReceivedTime,"/","-")
                  rtime = Replace(rtime,":","-")
                  savefile = savepath
                  savefile = savefile & attname & " (" & rtime & ")." & attext
                  If attname <> "Paperclip" AND attext <> "ico" Then
                        On Error Resume Next
                        objAttachment.SaveToFile savefile
                        On Error Goto 0
                        attarray(arrcnt) = savefile
                        attnarray(arrcnt) = objAttachment.FileName
                        arrcnt = arrcnt + 1
                  End If
            Next
            If attname <> "Paperclip" AND attext <> "ico" Then
                  If Err.Number = 0 Then
                        msgobj.Attachments.DeleteAll
                        msgobj.AddAttachment "C:\Program Files\Exchsrvr\BIN\Paperclip.ico"
                        If msgobj.HTMLBody <> "" Then
                              If Instr(1, msgobj.HTMLBody, "</BODY") > 0 Then
                                    sHTMLBody = Left(msgobj.HTMLBody, Instr(1, msgobj.HTMLBody, "</BODY>") - 1)
                              Else
                                    sHTMLBody = msgobj.HTMLBody
                              End if
                        End If
                        For I = 1 to attachcount
                              msgobj.TextBody = msgobj.TextBody & vbCRLF & "****** Attachment: " & attnarray(i) & " <file://" & attarray(i) & ">"
                              sHTMLBody = sHTMLBody & vbCRLF & "<BR><B><DIV><FONT face=Arial color=#004000 size=2>****** Attachment: <A href=" & chr(34) & " file://" & attarray(i) & chr(34) & "> " & attnarray(i) & "</A></DIV>"
                        Next
                        If msgobj.HTMLBody <> "" Then
                              msgobj.HTMLBody = sHTMLBody & "<BR><BR></BODY></HTML>"
                        End If
                        msgobj.TextBody = msgobj.TextBody & vbCRLF & vbCRLF
                        msgbox msgobj.datasource.isdirty
                        msgobj.DataSource.Save    'error occurs here
                  End If
            End If
            Set msgobj = Nothing
            rs.MoveNext
      Wend
End If
Set rs = Nothing
Set conn = Nothing
Msgbox "done"

The error I get is:
Error: Unspecified Error
Code: 80004005
Source: CDO.Message.1

Ive tried just removing the attachment and saving, just adding an attachment as saving and just altering the text of the message body and saving.  I still get the same error each time (a hearty THANK YOU to MS for such descriptive error message btw).  Also, another strange thing is that when I check the IsDirty property of DataSource it says False?  Any thoughts or ideas?
Avatar of bandolex2
bandolex2

Try folder and iis permissions.
Avatar of Wilbat

ASKER

I checked the folder permissions through Outlook and the user account Im runninghte script as has Owner permissions.  I also checked the Administrative Rights in Exchange and it has full rights there as well.  IIS is setup for Integrated Windows authentication only so the permissions under the Exchange Administrative Rights should dictate to IIS unless Im mistaken.
So it doens't appear to be a permissions issue.
an this folder?
svcdir = "C:\temp\~Test Client"

in windows?
also that ~ looks weird
Avatar of Wilbat

ASKER

That is the folder the script creates to save the attachments in.  It has no problem creating the folder or saving the attachments in it.  That part works fine.  It's just when I try saving the changes Ive made to the CDO.Message object.
try changing msgobj.DataSource.Save    for    msgobj.DataSource.Close
if not im empty of thoughts or ideas
ASKER CERTIFIED SOLUTION
Avatar of bandolex2
bandolex2

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Wilbat

ASKER

Update:  When I was getting the error I was logged into the Exchange Server as administrator and just double clicking on the .VBS file.
Just as a swing in the dark I setup the script to run via a Scheduled Task using Administrator for the credentials and it worked.  Not sure why but it obviously did have something to do with permissions so Im gonna give you the points for pointing me in the right direction.
Thanks!
Thank you for the points!
band.