Thanks for this. I think that I have handled errors and released all
object and it still seems to hang. The code I have written is
below
the code is from a user form which is my progress bar). I then
just have a very simple Userform1.show which kicks the main code off.
Thanks
-----------------------
Private Sub UserForm_Activate()
On Error GoTo ErrOutput
Dim Myxls As Object
Dim myNS As NameSpace
Dim myInbox As MAPIFolder
Dim msg As Object
Dim ToBeMoved() As MailItem
Dim NumberToMove As Integer
Dim idx As Integer
ErrorFlag = 0
' Resize the UserForm
Me.Width = 240
Me.Height = 60
' Resize the label
Me.Label1.Height = 25
Me.Label1.Caption = ""
Me.Label1.Width = 1
Me.Label1.BackColor = wdColorBlue
Set myNS = GetNamespace("MAPI")
Set myInbox = Nothing
For Each f1 In myNS.Folders
If f1 = "Mailbox - Info Centre" Then
For Each f2 In f1.Folders
If f2 = "Inbox" Then
Set myInbox = f2
End If
Next
End If
Next
Set f1 = Nothing
Set f2 = Nothing
Set Myxls = CreateObject("Excel.application")
'Myxls.Application.Visible = True
Myxls.Application.Workbooks.Open
FileName:="U:\SASXV001Data\SasData\Live\InfoCentre Outlook Rules.xls"
TotalRules = Myxls.Application.Cells(1, 5)
MaxWidth = 210
pc = MaxWidth / TotalRules
i = Empty
For i = 2 To 10000
NewWidth = pc * i
Me.Label1.Width = NewWidth
Me.Repaint
If Myxls.Application.Cells(i, 1) <> "" Then
Message = Myxls.Application.Cells(i, 1)
FolderVar = Myxls.Application.Cells(i, 2)
Call Process(myInbox, NumberToMove, ToBeMoved, Message, myNS,
FolderVar, Dest, f1, f2, f3, f4, msg)
End If
If Myxls.Application.Cells(i, 1) = "" Then i = 99999
Next i
Myxls.Application.Quit
Unload Me
GoTo Final
ErrOutput:
Unload Me
Myxls.Application.Quit
ErrorFlag = 1
Text = "Processing Failed at row " & i & " of the Excel Spreadsheet.
The subject of the email to be moved was: '" & Message & "'.
Processing will now terminate without completing"
var = MsgBox(Text, vbCritical, "Info Centre VBA Rules")
Final:
'Final Tidy
Set myInbox = Nothing
Set myNS = Nothing
Set Myxls = Nothing
If ErrorFlag = 0 Then var = MsgBox("InfoCentre VBA Rules Processing
Complete", vbInformation, "Info Centre VBA Rules")
End Sub
Public Sub Process(myInbox, NumberToMove, ToBeMoved, Message, myNS,
FolderVar, Dest, f1, f2, f3, f4, msg)
Call Scan(myInbox, NumberToMove, ToBeMoved, Message)
Call FindFolder(myNS, FolderVar, Dest)
Call MoveItem(NumberToMove, ToBeMoved, Dest)
Call Cleanup(myNS, myInbox, f1, f2, f3, f4, Dest, msg)
End Sub
Public Sub Cleanup(myNS, myInbox, f1, f2, f3, f4, Dest, msg)
Set f1 = Nothing
Set f2 = Nothing
Set f3 = Nothing
Set f4 = Nothing
Set Dest = Nothing
Set msg = Nothing
End Sub
Public Sub Scan(myInbox, NumberToMove, ToBeMoved, Message)
'Scan For Messages
NumberToMove = 0
For Each msg In myInbox.Items
'Process only mail messages.
If TypeOf msg Is MailItem Then
If msg.Subject Like Message And msg.SenderName = "SQL Mail
Account" Then
NumberToMove = NumberToMove + 1
ReDim Preserve ToBeMoved(NumberToMove)
Set ToBeMoved(NumberToMove) = msg
End If
End If
Next
End Sub
Public Sub FindFolder(myNS, FolderVar, Dest)
Set Dest = Nothing
For Each f1 In myNS.Folders
If f1 = "Mailbox - Info Centre" Then
For Each f2 In f1.Folders
If f2 = "Inbox" Then
For Each f3 In f2.Folders
If f3 = FolderVar Then
Set Dest = f3
End If
For Each f4 In f3.Folders
If f4 = FolderVar Then
Set Dest = f4
End If
Next
Next
End If
Next
End If
Next
End Sub
Public Sub MoveItem(NumberToMove, ToBeMoved, Dest)
If NumberToMove > 0 Then
For idx = 1 To NumberToMove
ToBeMoved(idx).Move Dest
Next
End If
End Sub
