Getting 2950 when running Macro

bjreb

Registered User.
Local time
Today, 14:31
Joined
May 7, 2001
Messages
37
I am getting a 2950 error when I try to run this with RunCode from the macro menu but it runs fine when run from the VBA editor. I am using 07 and the file is a trusted folder

Can you see anything wrong?

DoCmd.SetWarnings False

Set aOutapp = CreateObject("Outlook.application")
Set ns = aOutapp.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set fProcessed = Inbox.Folders("Completed")
Set fException = Inbox.Folders("Exceptions")
Set oReceived = Inbox.Folders("Received")



i = oReceived.Items.Count
If i = 0 Then
' MsgBox "There are no messages in the Inbox.", vbInformation, _
'"Nothing Found"
Exit Function
End If
'Set safemail = CreateObject("Redemption.SafemailItem")
iCount = 1
For i = i To 1 Step -1
Set oMail = oReceived.Items(i)
'oMail.Item = oMail
Name = oMail.SenderName
If Name = "Dick St. Laurent" Then
Name = "Dick St.Laurent"
End If
dtSent_Date = oMail.ReceivedTime
dCreateDate = oMail.CreationTime
sSubject = oMail.Subject




sSubject = oMail.Subject
sSubject = Replace(sSubject, "cases", "")
sSubject = Replace(sSubject, "FW: ", "")
sSubject = Replace(sSubject, "cs", "")
sSubject = Replace(sSubject, "case", "")
sSubject = Replace(sSubject, " ", "")
iNumber = Asc(Mid(sSubject, 1, 1))
iTestLen = Len(sSubject)
If iTestLen < 8 Then
GoTo NextPlease:
End If
iTest = 1
Do Until iTest = iTestLen
sTestString = Asc(Mid(sSubject, iTest, 1))

Select Case sTestString
Case 0 To 31
'MsgBox sTestString & " under 31"
sTableMove = "Exceptions"
GoTo NextPlease:
Case 33 To 47
'MsgBox sTestString & " 33 to 47"
sTableMove = "Exceptions"
GoTo NextPlease:
Case 48 To 58
GoTo NextTest:
Case 59 To 200
'MsgBox sTestString & " 59 to 200"
sTableMove = "Exceptions"
GoTo NextPlease:
End Select
NextTest:
iTest = iTest + 1
Loop



sTableMove = "Completed"
ItsaString:
sSql = "select DateProcessed from dbo_tblIncentives " & _
"Where DateProcessed = #" & dCreateDate & "#"

Set rs2 = CurrentDb.OpenRecordset(sSql)
rsCount = rs2.RecordCount
If rsCount > 0 Then
GoTo NextPlease:
Set rs2 = Nothing
End If
If Name = "Lori Tibbetts" Then
Name = "Dick St.Laurent"
End If

sSql = "select repemail from dbo_tblreps where repname = '" & Name & "'"
Debug.Print sSql
Set rs2 = CurrentDb.OpenRecordset(sSql)


sEmailAddress = rs2.Fields("repemail")

Set rs2 = Nothing



sBody = FixString(sSubject)


sProgram = Mid(sSubject, 1, 5)
sAccount = Mid(sSubject, 7, 5)
If Len(sSubject) > 11 Then
iCases = Int(Mid(sSubject, 12, 3))
Else
iCases = 0
End If


GD = CreateGUID()
Debug.Print GD








sSql = "Insert into dbo_tblIncentives(ID,Fromemail,accnum,prognum,CSqty,DateProcessed)" & _
"Values('" & GD & "','" & sEmailAddress & "','" & sProgram & "','" & sAccount & "'," & iCases & ",'" & dtSent_Date & "' )"
Debug.Print sSql
DoCmd.RunSQL (sSql)
' If InStr(1, Name, ".") > 0 Then
' MsgBox "hold"
'End If

sFirstInitial = Mid(Name, 1, 1)
sLastName = Replace(Mid(Name, InStr(1, Name, " ") + 1, Len(Name) - InStr(1, Name, " ") + 1), ".", "")
sNameConcat = StrConv(sFirstInitial & sLastName, vbLowerCase)
Debug.Print sNameConcat

' Save any attachments found
For Each atmt In oMail.Attachments
' This path must exist! Change folder name as necessary.
' sPhotoString = sPhotoString1 & "_" & I
FileName = atmt
If FileName Like "*.txt" Then
GoTo NextPlease
Else
FileName = "C:\Link\Temp.jpg"
atmt.SaveAsFile FileName
sSql = "Insert into dbo_tblImage (ID,Process_Date) " & _
"Values (" & GD & ",'" & dtSent_Date & "')"
DoCmd.RunSQL (sSql)
vAddphotolink = "ID = " & GD

' DoCmd.OpenForm "frmAdd_Image", , , vAddphotolink, , acHidden
DoCmd.OpenForm "frmAdd_Image", , , vAddphotolink, , acHidden
DoCmd.Close acForm, "frmAdd_Image", acSaveYes
End If

Next atmt


NextPlease:

Debug.Print i
'sSql = "insert into " & sTableMove & """" & _
"select * from inbox where received = " & process_date & """"
sSubject = ""
oMail.UnRead = False
If sTableMove = "Exceptions" Then
oMail.Move fException
Else
oMail.Move fProcessed

End If

'rs.MoveNext
Next
'Call MoveItems_w_attach
GetAttachments_exit:
Set aOutapp = Nothing
Set ns = Nothing
Set atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Function


' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit



Thanks

Andy
 

Users who are viewing this thread

Back
Top Bottom