July 25, 2008 02:24pm pdt

1. GrahamSkan 333,262
2. PaulHews 313,795
3. matthews... 233,559
4. RobSamp... 215,225
5. zorvek 204,802
6. jpaulino 189,984
7. rorya 155,790
8. Idle_Mind 130,882
9. angelIII 118,047
10. danaseaman 94,710
11. robinu 92,294
12. TRobinJa... 89,395
13. capricorn1 87,302
14. ee_rlee 78,807
15. BlueDevilF... 77,075

1. Idle_Mind 1,757,418
2. PaulHews 1,446,734
3. AzraSound 1,400,747
4. GrahamSkan 1,371,117
5. vinnyd79 1,242,790
6. angelIII 1,215,273
7. Erick37 1,211,724
8. EDDYKT 1,134,094
9. emoreau 1,086,417
10. TimCottee 980,716
11. matthews... 869,015
12. Ark 856,902
13. ryancys 856,267
14. BlueDevilF... 815,652
15. Shauli 718,021

04.18.2008 at 07:05AM PDT, ID: 23334181

	[x] Attachment Details

[x]

The Solution Rating System

With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.

The Grade of the Solution
The Zone Rank of the Expert Providing the Solution
The Number of Author and Expert Comments
The Number of Experts Contributing
The Feedback of the Community

Your Input Matters
Because of the way the system is set up, the most important variable in this equation is you. As a member of Experts Exchange, you are able to cast your vote on the quality of the solutions in regard to how complete, accurate, helpful and easy to understand each solution is. When you provide your feedback, each rating is adjusted accordingly. So, if you see a solution that has a poor rating that you think is a good solution, let us know by rating it. As you do, the rating will be adjusted and will become more accurate for other members of our site.

If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support.

Thank you!

9.0

OL2003 & VBA - Object or With block not set (runtime91) errors in outlook vba code. (Sometimes can debug, other times application errors)

Zones: Visual Basic Programming, Outlook Groupware Software

Tags: Microsoft, Outlook, 2003, VBA - WithEvents

I have the following VBA code in my Outlook "ThisOutlookSession"
When it starts up I keep getting "Object Variable or With block variable not set"
However it has worked fine before and usually if I just re-started the macro it would run fine.

When I do get the option to "Debug" this is the line highlighted in yellow.
Set stcFolders = stFolder.Folders (line 42)

         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:

           
           
             Public WithEvents myOlItems As Outlook.Items
Public WithEvents myTDiItems As Outlook.Items
Public WithEvents myTDnItems As Outlook.Items
Public WithEvents myTDwItems As Outlook.Items
 
Public Sub Application_Startup()
 
   ' Reference the items in the Inbox. Because myOlItems is declared
   ' "WithEvents" the ItemAdd event will fire below.
   Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items
   
   Dim tdiFolder As MAPIFolder
   Set tdiFolder = GetFolderByName("! Immediately")
   Set myTDiItems = tdiFolder.Items
   
   Dim tdnFolder As MAPIFolder
   Set tdnFolder = GetFolderByName("! Need Something")
   Set myTDnItems = tdnFolder.Items
   
   Dim tdwFolder As MAPIFolder
   Set tdwFolder = GetFolderByName("! When Permitting")
   Set myTDwItems = tdwFolder.Items
 
End Sub
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeOf Item Is Outlook.MailItem Then
        Dim objMe As Recipient
        Set objMe = Item.Recipients.Add("firstname.lastname@biz.com")
        objMe.Type = olBCC
        objMe.Resolve
        Set objMe = Nothing
    End If
End Sub
 
Private Sub myOlItems_ItemAdd(ByVal rEmail As Object)
 
    ' Loop through "@ Sent Tracking" subfolders
    Dim stcFolders As Folders
    Dim stFolder As MAPIFolder
    Set stFolder = GetFolderByName("@ Sent Tracking")
    Set stcFolders = stFolder.Folders
 
    If TypeOf rEmail Is Outlook.ReportItem Then
'        Debug.Print ("receipt " & Left(rEmail.ConversationIndex, 44))
        
        ' If received read receipt, reduce flag colour by 2 (staying within warm colours)
        If Left$(rEmail.Subject, 5) = "Read:" Then
            Dim bSuccess_read As Boolean
            
                For Each Folder In stcFolders
 
                    ' Flag management
                    Set myRRItems = Folder.Items
                    
                    For Each Item In myRRItems
'                        Debug.Print ("possible original " & Left(Item.ConversationIndex, 44) & " " & Item.Subject)
                        If Left(Item.ConversationIndex, 44) = Left(rEmail.ConversationIndex, 44) Then
'                            Debug.Print ("original " & Left(Item.ConversationIndex, 44))
                            If TypeOf Item Is Outlook.MailItem Then
                                Set Mail = Item
                                    If Mail.FlagIcon = 0 Then
                                        Mail.FlagStatus = olNoFlag
                                    Else
                                        Mail.FlagIcon = Mail.FlagIcon - 2
                                        If Mail.FlagIcon < 0 Then
                                            Mail.FlagIcon = 0
                                            Mail.FlagStatus = olNoFlag
                                        End If
                                    End If
                                Mail.Save
                            End If
                            bSuccess_read = True
                            rEmail.UnRead = False
                            rEmail.Delete
                            Exit Sub
                        End If
                    Next Item
                
                Next Folder
                
                ' No match found
                'If bSuccess_read = False Then
                    'MsgBox ("No matching flagged message found for read receipt!")
                'End If
        
        ' If received not read receipt, increase flag colour by 2 (staying within warm colours)
        ElseIf Left$(rEmail.Subject, 9) = "Not Read:" Then
            Dim bSuccess_notread As Boolean
            
                For Each Folder In stcFolders
                      
                    ' Flag Management
                    Set myNRItems = Folder.Items
                    
                    For Each Item In myNRItems
                        If Left(Item.ConversationIndex, 44) = Left(rEmail.ConversationIndex, 44) Then
'                            Debug.Print ("original " & Left(Item.ConversationIndex, 44))
                            If TypeOf Item Is Outlook.MailItem Then
                                Set Mail = Item
                                Mail.FlagIcon = Mail.FlagIcon + 2
                                    If Mail.FlagIcon > 6 Then
                                        Mail.FlagIcon = 6
                                    End If
                                Mail.Save
                            End If
                            bSuccess_notread = True
                            rEmail.UnRead = False
                            rEmail.Delete
                            Exit Sub
                        End If
                    Next Item
                    
                Next Folder
                
                ' No match found
                'If bSuccess_notread = False Then
                    'MsgBox ("No matching flagged message found for not read receipt!")
                'End If
                
        End If
    
    ElseIf TypeOf rEmail Is Outlook.MailItem Then
        
        ' If received reply, reduce flag colour by 2 (staying within warm colours)
        If Left$(rEmail.Subject, 3) = "RE:" Then
'            Debug.Print ("reply " & Left(rEmail.ConversationIndex, 44))
            Dim bSuccess_reply As Boolean
            
                For Each Folder In stcFolders
 
                    ' Flag management
                    Set myREItems = Folder.Items
                    
                    For Each Item In myREItems
                        If Left(Item.ConversationIndex, 44) = Left(rEmail.ConversationIndex, 44) Then
'                            Debug.Print ("original " & Left(Item.ConversationIndex, 44))
                            If TypeOf Item Is Outlook.MailItem Then
                                Set Mail = Item
                                    If Mail.FlagIcon = 0 Then
                                        Mail.FlagStatus = olNoFlag
                                    Else
                                        Mail.FlagIcon = Mail.FlagIcon - 2
                                        If Mail.FlagIcon < 0 Then
                                            Mail.FlagIcon = 0
                                            Mail.FlagStatus = olNoFlag
                                        End If
                                    End If
                                Mail.Save
                            End If
                            bSuccess_reply = True
                            rEmail.UnRead = False
                            Exit Sub
                        End If
                    Next Item
                
                Next Folder
                
                ' No match found
                'If bSuccess_reply = False Then
                    'MsgBox ("No matching flagged message found for reply!")
                'End If
        End If
        
    End If
    
End Sub
 
Private Sub myTDiItems_ItemAdd(ByVal rEmail As Object)
    If TypeOf rEmail Is Outlook.MailItem Then
        Dim strID As String
        Dim olNS As Outlook.NameSpace
        Dim oMail As Outlook.MailItem
    
        strID = rEmail.EntryID
        Set olNS = Application.GetNamespace("MAPI")
        Set oMail = olNS.GetItemFromID(strID)
    
        If oMail.To = "LASTNAME Firstname" Then
            oMail.FlagIcon = 6
            oMail.FlagStatus = olFlagMarked
            oMail.FlagDueBy = DateAdd("d", 1, Now())
            oMail.Save
            Set oMail = Nothing
            Set olNS = Nothing
            Exit Sub
        End If
    
        If oMail.CC = "LASTNAME Firstname" Then
            oMail.FlagIcon = 5
            oMail.FlagStatus = olFlagMarked
            oMail.FlagDueBy = DateAdd("d", 3, Now())
            oMail.Save
            Set oMail = Nothing
            Set olNS = Nothing
            Exit Sub
        End If
    
        Set oMail = Nothing
        Set olNS = Nothing
    End If
End Sub
 
Private Sub myTDnItems_ItemAdd(ByVal rEmail As Object)
    If TypeOf rEmail Is Outlook.MailItem Then
        Dim strID As String
        Dim olNS As Outlook.NameSpace
        Dim oMail As Outlook.MailItem
    
        strID = rEmail.EntryID
        Set olNS = Application.GetNamespace("MAPI")
        Set oMail = olNS.GetItemFromID(strID)
    
        If oMail.To = "LASTNAME Firstname" Then
            oMail.FlagIcon = 4
            oMail.FlagStatus = olFlagMarked
            oMail.FlagDueBy = DateAdd("d", 3, Now())
            oMail.Save
            Set oMail = Nothing
            Set olNS = Nothing
            Exit Sub
        End If
    
        If oMail.CC = "LASTNAME Firstname" Then
            oMail.FlagIcon = 3
            oMail.FlagStatus = olFlagMarked
            oMail.FlagDueBy = DateAdd("d", 5, Now())
            oMail.Save
            Set oMail = Nothing
            Set olNS = Nothing
            Exit Sub
        End If
    
        Set oMail = Nothing
        Set olNS = Nothing
    End If
End Sub
 
Private Sub myTDwItems_ItemAdd(ByVal rEmail As Object)
    If TypeOf rEmail Is Outlook.MailItem Then
        Dim strID As String
        Dim olNS As Outlook.NameSpace
        Dim oMail As Outlook.MailItem
    
        strID = rEmail.EntryID
        Set olNS = Application.GetNamespace("MAPI")
        Set oMail = olNS.GetItemFromID(strID)
    
        If oMail.To = "LASTNAME Firstname" Then
            oMail.FlagIcon = 2
            oMail.FlagStatus = olFlagMarked
            oMail.FlagDueBy = DateAdd("d", 7, Now())
            oMail.Save
            Set oMail = Nothing
            Set olNS = Nothing
            Exit Sub
        End If
    
        If oMail.CC = "LASTNAME Firstname" Then
            oMail.FlagIcon = 1
            oMail.FlagStatus = olFlagMarked
            oMail.FlagDueBy = DateAdd("d", 14, Now())
            oMail.Save
            Set oMail = Nothing
            Set olNS = Nothing
            Exit Sub
        End If
    
        Set oMail = Nothing
        Set olNS = Nothing
    End If
End Sub
           
         

Start your free trial to view this solution

Question Stats

Zone: Programming

Question Asked By: natsirtm

Solution Provided By: BlueDevilFan

Participating Experts: 1

Solution Grade: B

Translate:

Loading Advertisement...

20080236-EE-VQP-29 / EE_QW_2_20070628