PeterNZ
07-30-2010, 09:02 PM
Hi Guys (excel 2003, win xp, outlook 2003)
So when the loop is finished and it so happens that no items meet all the criteria in the loop I need to have a msgbox pop-up saying " no email messages for the area picked "
All help greatly appreciated
Option Explicit
Public areaPicked As String
Sub Picture77_Click()
frmSendToArea.Show
End Sub
Sub AreaEmailAction()
Dim irow As Integer
Dim prow As Integer
Dim Who As String
Dim messagebody As String
Dim objmsg
Dim objOutlook As Object
If areaPicked = vbNullString Then
MsgBox ("Please select and area first!")
Exit Sub
End If
irow = 12
Do Until irow = 3000 Or Sheets("Action").Cells(irow, 1) = ""
Sheets("Action").Cells(irow, 17) = ""
irow = irow + 1
Loop
messagebody = "Here are your actions from the problem Solve register. Please update your actions or email to your relevant OE resource:" & Chr(10)
irow = 12
Do Until irow = 3000 Or Sheets("Action").Cells(irow, 1) = ""
Who = Sheets("Action").Cells(irow, 6)
prow = irow
Do Until prow = 3000 Or Sheets("Action").Cells(prow, 1) = ""
If Sheets("Action").Cells(prow, 17) = "" Then
If Sheets("Action").Cells(prow, 6) = Who Then
If Sheets("Action").Cells(prow, 8) = "" Then
If Sheets("Action").Cells(prow, 3) = areaPicked Then
messagebody = messagebody _
& Chr(10) _
& Sheets("Action").Cells(prow, 1) & ". " _
& " Problem Solve: " & Sheets("Action").Cells(prow, 2) & " Department: " _
& Sheets("Action").Cells(prow, 3) _
& Chr(10) & "Issue: " _
& Sheets("Action").Cells(prow, 4) _
& Chr(10) & "Action: " _
& Sheets("Action").Cells(prow, 5) _
& Chr(10) & "Due Date: " & Sheets("Action").Cells(prow, 7) _
& Chr(10) & "-------------------------------------//-------------------------------------" & Chr(10)
Sheets("Action").Cells(prow, 17) = False
End If
End If
End If
End If
prow = prow + 1
Loop
If messagebody <> "Here are your actions from the problem Solve register. Please update your actions or email to your relevant OE resource:" & Chr(10) Then
Set objOutlook = CreateObject("Outlook.application")
Set objmsg = objOutlook.CreateItem(0)
objmsg.Subject = "Issue - Actions "
objmsg.Display
objmsg.To = Who
objmsg.body = messagebody
'objmsg.Send
messagebody = "Here are your actions from the problem Solve register. Please update your actions or email to your relevant OE resource:" & Chr(10)
End If
irow = irow + 1
Loop
areaPicked = vbNullString
Set objOutlook = Nothing
Set objmsg = Nothing
End Sub
So when the loop is finished and it so happens that no items meet all the criteria in the loop I need to have a msgbox pop-up saying " no email messages for the area picked "
All help greatly appreciated
Option Explicit
Public areaPicked As String
Sub Picture77_Click()
frmSendToArea.Show
End Sub
Sub AreaEmailAction()
Dim irow As Integer
Dim prow As Integer
Dim Who As String
Dim messagebody As String
Dim objmsg
Dim objOutlook As Object
If areaPicked = vbNullString Then
MsgBox ("Please select and area first!")
Exit Sub
End If
irow = 12
Do Until irow = 3000 Or Sheets("Action").Cells(irow, 1) = ""
Sheets("Action").Cells(irow, 17) = ""
irow = irow + 1
Loop
messagebody = "Here are your actions from the problem Solve register. Please update your actions or email to your relevant OE resource:" & Chr(10)
irow = 12
Do Until irow = 3000 Or Sheets("Action").Cells(irow, 1) = ""
Who = Sheets("Action").Cells(irow, 6)
prow = irow
Do Until prow = 3000 Or Sheets("Action").Cells(prow, 1) = ""
If Sheets("Action").Cells(prow, 17) = "" Then
If Sheets("Action").Cells(prow, 6) = Who Then
If Sheets("Action").Cells(prow, 8) = "" Then
If Sheets("Action").Cells(prow, 3) = areaPicked Then
messagebody = messagebody _
& Chr(10) _
& Sheets("Action").Cells(prow, 1) & ". " _
& " Problem Solve: " & Sheets("Action").Cells(prow, 2) & " Department: " _
& Sheets("Action").Cells(prow, 3) _
& Chr(10) & "Issue: " _
& Sheets("Action").Cells(prow, 4) _
& Chr(10) & "Action: " _
& Sheets("Action").Cells(prow, 5) _
& Chr(10) & "Due Date: " & Sheets("Action").Cells(prow, 7) _
& Chr(10) & "-------------------------------------//-------------------------------------" & Chr(10)
Sheets("Action").Cells(prow, 17) = False
End If
End If
End If
End If
prow = prow + 1
Loop
If messagebody <> "Here are your actions from the problem Solve register. Please update your actions or email to your relevant OE resource:" & Chr(10) Then
Set objOutlook = CreateObject("Outlook.application")
Set objmsg = objOutlook.CreateItem(0)
objmsg.Subject = "Issue - Actions "
objmsg.Display
objmsg.To = Who
objmsg.body = messagebody
'objmsg.Send
messagebody = "Here are your actions from the problem Solve register. Please update your actions or email to your relevant OE resource:" & Chr(10)
End If
irow = irow + 1
Loop
areaPicked = vbNullString
Set objOutlook = Nothing
Set objmsg = Nothing
End Sub