• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Looping issue excel

I

IKHAN

Member
Hello,Need help!!! with excel Macro to pull data from third party application and email the body to outlook if any data present ,below macro does it however need some help Tweakin it.


ISSUE : Below MACRO goes in a loop after displaying results in excel sheets and not able to call/send email unless i run email macro (Sub Mail_Selection_Range_Outlook_Body())separately.

-lookin for macro to run every 30 minutes and email the body, if query is empty no email.

Private Sub Workbook_Open()

' This procedure clears the username and password fields
' on the login worksheet when the workbook is opened.

Worksheets("Login").Cells(3, 2) = ""
Worksheets("Login").Cells(4, 2) = ""
Worksheets("Login").Activate
Range("B3").Activate

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

' This procedure clears the username and password fields
' on the login worksheet when the workbook is closed.

Worksheets("Login").Cells(3, 2) = ""
Worksheets("Login").Cells(4, 2) = ""

End Sub

Public Sub Run_Query()

' This procedure reads the query from the active worksheet
' and passes the string to the RetrieveRecordSet function.
' The two variables passed to the RetrieveRecordSet function
' are the query string and the destination cell of where to
' display the resulting query, in this case, cell A10.

Dim sSQL As String
Dim check
Dim RowCount As Long
Dim Incident As String
Dim IncidentDate As Date

check = True
RowCount = 10
sSQL = Cells(3, 2)

Do

' Pull the incidents from Remedy
Call RetrieveRecordSet(sSQL, [A10])
' ActiveWorkbook.PrecisionAsDisplayed = False

' Now check the duration for each incident

RowCount = 10
Incident = Cells(RowCount, 1)
IncidentDate = Cells(RowCount, 4)

While Incident > ""

' Calculate the duration in minutes

If DateDiff("n", IncidentDate, Now) > 60 Then

'ActiveWorkbook.SendMail Recipients:="xxx"

End If

RowCount = RowCount + 1
Incident = Cells(RowCount, 1)
IncidentDate = Cells(RowCount, 4)

Wend

Application.Wait (Now + TimeValue("0:00:10"))

' Clear all the incidents
Range("A10:AZ50000").Select
Selection.ClearContents

Loop Until check = False

End Sub

Public Sub RetrieveRecordSet(strSQL As String, clTrgt As Range)

Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim dbConn As String
Dim uName As String
Dim uPassword As String

' Clear the contents of the destination cells
Range("A10:az50000").Select
Selection.ClearContents

' The username and password are read from the login worksheet and
' stored in the uName and uPassword fields.
uName = Worksheets("Login").Cells(3, 2)
uPassword = Worksheets("Login").Cells(4, 2)

' The following routine checks if the Remedy username and/or password
' variables are blank. If they are, a message is displayed and
' the user must enter the missing information.
If (uName = "" Or uPassword = "") Then
Worksheets("Login").Activate
If (uName = "" And uPassword = "") Then
MsgBox ("The Remedy username and password fields are blank. Please confirm your login details.")
Worksheets("Login").Range("B3").Activate
Exit Sub
End If
If uName = "" Then
MsgBox ("The Remedy username field is blank. Please enter your username.")
Worksheets("Login").Range("B3").Activate
Exit Sub
End If
If uPassword = "" Then
MsgBox ("The Remedy password field is blank. Please enter your password.")
Worksheets("Login").Range("B4").Activate
Exit Sub
End If
Exit Sub
End If

' Set database source. The connection string is stored in the string dbConn.
dbConn = "DSN=AR System ODBC Data Source;ARServer=xxxxxxxx
;ARServerPort=xxxx;UID=" + uName + ";PWD=" + uPassword + ";ARAuthentication=;SERVER=NotTheServer"

'Create RecordSet
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset

Cn.ConnectionString = dbConn
Cn.Open

' The following establishes the connection to the Remedy datasource and
' and passes the resulting dataset back to ht RS recordset.
With Rs
Rs.ActiveConnection = Cn
Rs.Open strSQL
If (Rs.EOF) Then
' MsgBox ("Query is empty")
Else
clTrgt.CopyFromRecordset Rs
ActiveSheet.Calculate
'ActiveWorkbook.Worksheets("Sample Query").Range(clTrgt).CopyFromRecordset Rs
End If
Rs.Close
End With

On Error Resume Next
If Err.Number <> 0 Then GoTo EarlyExit

EarlyExit:

' This closes/clears all the variables.
Rs.Close
Cn.Close
Set clTrgt = Nothing
Set Cn = Nothing
Set Rs = Nothing

End Sub

Public Sub Run_AllQuery()

' This procedure scans the support worksheet for all the worksheet names
' and runs the RetrieveRecordSet function for every worksheet listed.

Dim RowCount As Long
Dim sSQL As String
Dim WSName As String

' Turn off screen updating and set auto calculation to manual.
Application.ScreenUpdating = False
Application.Calculation = xlManual

WSName = ""
Worksheets("Support").Activate

' This sets the starting row number for the worksheets.
RowCount = Cells(2, 2)

While Cells(RowCount, 2) > ""
On Error Resume Next

WSName = Cells(RowCount, 2)
Worksheets(WSName).Activate
sSQL = Cells(3, 2)
Call RetrieveRecordSet(sSQL, [A10])

sSQL = ""
WSName = ""

Worksheets("Support").Activate
RowCount = RowCount + 1

Wend

' Turn on screen updating, activate the login worksheet, turn on auto calculation, and
' force a recalculation of the workbook.
Application.ScreenUpdating = True
Worksheets("Login").Activate
Application.Calculation = xlAutomatic
Calculate

End Sub

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next

Set rng = Selection.SpecialCells(xlCellTypeVisible)

Set rng = Sheets("Incident Scanning").Range("A9:A15", "L9:L15").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = "xxx@yahoo.ca"
.CC = ""
.BCC = ""
.Subject = "Test email from Excel"
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 
I think you need to just include an OnTime event to run your macro every 30 minutes. Within your macro, I believe you're already checking if there's no need to sent the email.

OnTime link:

http://www.ozgrid.com/Excel/run-macro-on-time.htm
 
You must log in or register to reply here.
Back
Top