Hello everyone,
I am having an issue that hopefully will not be to difficult to figure out. I am having a bear of a time with it. I will post the code below.
I am using Excel 2003, and connecting to a remote Access 2003 database.
Ok here is my issue, If I place a break point in where I have shown here in my code example, and step through the for loop one at a time, everything works just fine. As soon as I try to remove the break point and let it run on its own, it gets locked up. I have tried Application wait times up to 5 seconds, and still the same issue. Any help with this would be greatly appreciated.
I Had to remove a few lines because they contained a linking method to the access database through h t t p protocol and since im new here I have less than 5 posts. I am also not a troller or speed poster so I am not going to cheat the system to get them.
[vba]Option Explicit
Sub RunReport_Button()
Results
End Sub
Sub ClearReport_Button()
ClearReport (True)
End Sub
Private Sub Results()
'Error handling, used to trap and take action on specific types of errors.
On Error GoTo Exception
Dim Configuration As Worksheet
Dim ServerRange As Range
Dim Status As Range
Dim OverrideEvent As Range
Dim DurationEvent As Range
Dim RateMin As Range
Dim TotalAmt As Range
Dim EndOverrideEvent As Range
Dim EventStartTime As Range
Dim EventEndTime As Range
Dim EventDuration As Range
Dim EventTotal As Range
Dim TotalField As Currency
Dim DurationTime As Integer
Dim ReportTotal As Integer
Dim DurationStart As Date
Dim TotalEventDuration As Date
Dim TrendStartDate, TrendEndDate, Tempdate As Date
Dim Server As String
Dim Username As String
Dim Password As String
Dim ResultsTrend() As String
Dim ResultsTrend2() As String
Dim OverrideTemp(50) As Worksheet
Dim RefreshResults As String
Dim Value As Range
Dim NewRow As Integer
Dim Expression As Range
Dim Description As Range
Dim Config_Electric As Worksheet
Dim Error_Page As Worksheet
Dim Error As Range
Dim Unprotect As Integer
Dim Protect As Integer
Dim k As Integer
Dim test1 As String
Dim test2 As String
Dim DateMult As Integer
Dim DateTest As Date
Dim ValDate As Date
Set Configuration = Worksheets("Configuration")
Set OverrideTemp(0) = Worksheets("Meter_1")
Set OverrideTemp(1) = Worksheets("Meter_2")
Set OverrideTemp(2) = Worksheets("Meter_3")
Set OverrideTemp(3) = Worksheets("Meter_4")
Set OverrideTemp(4) = Worksheets("Meter_5")
Set OverrideTemp(5) = Worksheets("Meter_6")
Set OverrideTemp(6) = Worksheets("Meter_7")
Set OverrideTemp(7) = Worksheets("Meter_8")
Set OverrideTemp(8) = Worksheets("Meter_9")
Set OverrideTemp(9) = Worksheets("Meter_10")
Set OverrideTemp(10) = Worksheets("Meter_11")
Set OverrideTemp(11) = Worksheets("Meter_12")
Set OverrideTemp(12) = Worksheets("Meter_13")
Set OverrideTemp(13) = Worksheets("Meter_14")
Set OverrideTemp(14) = Worksheets("Meter_15")
Set Config_Electric = Worksheets("Configuration_Electric")
Set Expression = Config_Electric.Range("GeoRefStart")
Set Description = Config_Electric.Range("DescriptionStart")
Set Value = Config_Electric.Range("ValueStart")
Set Error_Page = Worksheets("Error_Page")
Set Error = Configuration.Range("ErrorStatus")
Server = Configuration.Range("Host").Value
Set ServerRange = Configuration.Range("Host")
test1 = 100
test2 = 200
DateTest = "11/2/2006"
ClearReport (True)
'/////////////////////////////////////////////////////////'
'//This section unprotecs all the sheets in the workbook//'
'/////////////////////////////////////////////////////////'
'Configuration.Unprotect
For Unprotect = 0 To 14
OverrideTemp(Unprotect).Unprotect
Next
Config_Electric.Unprotect
'/////////////////////////////////////////////////////////'
'/////////////////////////////////////////////////////////'
'/////////////////////////////////////////////////////////'
Username = Configuration.Range("Username").Value
Password = Configuration.Range("Password").Value
'Get the start and end date.
TrendStartDate = Configuration.Range("StartDate").Value
TrendEndDate = Configuration.Range("EndDate").Value
' Advance the time on the end date to the last second of the day.
TrendEndDate = DateAdd("h", 23, TrendEndDate)
TrendEndDate = DateAdd("n", 59, TrendEndDate)
TrendEndDate = DateAdd("s", 59, TrendEndDate)
Set Status = Error_Page.Range("StatusStart")
For k = 0 To 14
Dim i, j, index, index2, size, size2, value1, value2, holder, indexholder As Integer
index = 0
'Get the trend data.
'/Application.Wait Now + TimeSerial(0, 0, 1)
'/BREAK =======>
ResultsTrend = GetTrendData(Server, Username, Password, TrendStartDate, TrendEndDate, 0, 0, OverrideTemp(k).Range("F1").Value, Status)
holder = Val(ResultsTrend(index + 1))
indexholder = index
DateMult = OverrideTemp(k).Range("X1").Value
' Results is time/value string pairs
' Compute size: result is 0 based, so add one to UBound to get size
size = (UBound(ResultsTrend) + 1) / 2
size2 = (UBound(ResultsTrend) + 1) / 2
TotalField = 0
Set EventStartTime = OverrideTemp(k).Range("B16")
Set EventDuration = OverrideTemp(k).Range("C16")
For i = 1 To size
j = i + 14
If (((size * 2) - 1) >= (index + 2)) Then
test2 = DateValue(ResultsTrend(index + 2))
Else
test2 = DateValue(ResultsTrend(index))
test2 = DateAdd("d", -1, test2)
End If
test1 = DateValue(ResultsTrend(index))
If (test1 = test2) Then
value1 = Val(ResultsTrend(index + 1))
value2 = Val(ResultsTrend(index + 3))
If (value1 <= value2) Then
holder = value2
indexholder = index + 2
End If
Else
'Insert the date from the extracted trend info.
OverrideTemp(k).Cells(EventStartTime.Row, EventStartTime.Column).Value = ResultsTrend(indexholder)
'OverrideTemp(k).Cells(EventStartTime.Row, EventStartTime.Column).Value = DateAdd("d", -1, OverrideTemp(k).Cells(EventStartTime.Row, EventStartTime.Column).Value)
OverrideTemp(k).Cells(EventStartTime.Row, EventStartTime.Column).HorizontalAlignment = xlCenter
ValDate = test1
If (ValDate < DateTest) Then
'Insert the value from the extracted trend info.
OverrideTemp(k).Cells(EventDuration.Row, EventDuration.Column).Value = holder * DateMult
OverrideTemp(k).Cells(EventDuration.Row, EventDuration.Column).NumberFormat = "0.0"
OverrideTemp(k).Cells(EventDuration.Row, EventDuration.Column).HorizontalAlignment = xlCenter
Else
'Insert the value from the extracted trend info.
OverrideTemp(k).Cells(EventDuration.Row, EventDuration.Column).Value = holder
OverrideTemp(k).Cells(EventDuration.Row, EventDuration.Column).NumberFormat = "0.0"
OverrideTemp(k).Cells(EventDuration.Row, EventDuration.Column).HorizontalAlignment = xlCenter
End If
test1 = ResultsTrend(index)
Set EventStartTime = OverrideTemp(k).Cells(EventStartTime.Row + 1, EventStartTime.Column)
Set EventDuration = OverrideTemp(k).Cells(EventDuration.Row + 1, EventDuration.Column)
End If
index = index + 2
Next
Erase ResultsTrend
ReDim ResultsTrend(0)
Next
'/Do
'/ RefreshResults = GetValue(Server, Username, Password, Expression.Value, Status)
'/ Value.Value = RefreshResults
'/NewRow = Expression.Row + 1
'/Set Expression = Config_Electric.Cells(NewRow, Expression.Column)
'/Set Description = Config_Electric.Cells(NewRow, Expression.Column - 1)
'/Set Value = Config_Electric.Cells(NewRow, Expression.Column + 1)
'/Loop Until (Expression.Value = "")
'//////////////////////////////////////////////////////////'
'///This section protects all the sheets in the workbook///'
'//////////////////////////////////////////////////////////'
'Configuration.Protect , _
DrawingObjects:=True, Contents:=True, Scenarios:=True
For Protect = 0 To 14
OverrideTemp(Protect).Protect , _
DrawingObjects:=True, Contents:=True, Scenarios:=True
Next
Config_Electric.Protect , _
DrawingObjects:=True, Contents:=True, Scenarios:=True
'/////////////////////////////////////////////////////////'
'/////////////////////////////////////////////////////////'
'/////////////////////////////////////////////////////////'
Sheets("Billing").Select
done:
Exit Sub
Exception:
Error.Value = "Errors were found, please see error page."
Error.Font.ColorIndex = 3
Status.Value = "Error: " & OverrideTemp(k).Range("F1").Value & " " & Err.Description
Set Status = Error_Page.Cells(Status.Row + 1, Status.Column)
Status.Font.ColorIndex = 3
'Debug.Print "Error: " & Err.Description
Resume Next
End Sub
Sub ClearReport(ByVal DisplayMsg As Boolean)
Dim Configuration As Worksheet
Dim SEvent As Range
Dim SEvent2 As Range
Dim Error_Page As Worksheet
Dim Status As Range
Dim Error As Range
Dim OverrideTemp(50) As Worksheet
Set OverrideTemp(0) = Worksheets("Meter_1")
Set OverrideTemp(1) = Worksheets("Meter_2")
Set OverrideTemp(2) = Worksheets("Meter_3")
Set OverrideTemp(3) = Worksheets("Meter_4")
Set OverrideTemp(4) = Worksheets("Meter_5")
Set OverrideTemp(5) = Worksheets("Meter_6")
Set OverrideTemp(6) = Worksheets("Meter_7")
Set OverrideTemp(7) = Worksheets("Meter_8")
Set OverrideTemp(8) = Worksheets("Meter_9")
Set OverrideTemp(9) = Worksheets("Meter_10")
Set OverrideTemp(10) = Worksheets("Meter_11")
Set OverrideTemp(11) = Worksheets("Meter_12")
Set OverrideTemp(12) = Worksheets("Meter_13")
Set OverrideTemp(13) = Worksheets("Meter_14")
Set OverrideTemp(14) = Worksheets("Meter_15")
Set Configuration = Worksheets("Configuration")
Set Error_Page = Worksheets("Error_Page")
Set Status = Error_Page.Range("StatusStart")
Set Error = Configuration.Range("ErrorStatus")
Dim k As Integer
'Configuration.Unprotect
Error.Value = ""
'Configuration.Protect , _
DrawingObjects:=True, Contents:=True, Scenarios:=True
Do
Status.Value = ""
Set Status = Error_Page.Cells(Status.Row + 1, Status.Column)
Loop While Not (Status.Value = "")
For k = 0 To 14
Set SEvent = OverrideTemp(k).Range("B16")
OverrideTemp(k).Select
OverrideTemp(k).Unprotect
Do
OverrideTemp(k).Rows(SEvent.Row).Select
Selection.ClearContents
Selection.Font.Bold = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Set SEvent = OverrideTemp(k).Cells(SEvent.Row + 1, SEvent.Column)
Set SEvent2 = OverrideTemp(k).Cells(SEvent.Row + 1, SEvent.Column)
Loop While (SEvent.Value = Empty & SEvent2.Value = Empty)
OverrideTemp(k).Protect , _
DrawingObjects:=True, Contents:=True, Scenarios:=True
Next
'Let the user know that the report is finished.
If (DisplayMsg) Then
Sheets("Billing").Select
'MsgBox "Report Data Cleared!"
End If
End Sub
Private Function GetTrendData(ByVal Server As String, ByVal Username As String, ByVal Password As String, ByVal StartDate As Date, ByVal EndDate As Date, ByVal LimitFromStart As Boolean, ByVal MaxRecords As Integer, ByVal TrendExpression As String, ByRef Status As Range) As String()
On Error GoTo Exception
Dim RetrieveAllTrends As Boolean
Dim URD As String
Dim client As MSSOAPLib30.SoapClient30
Dim Error_Page As Worksheet
Set Error_Page = Worksheets("Error_Page")
Set client = CreateObject("MSSOAP.SOAPClient30")
client.mssoapinit (URD)
client.ConnectorProperty("WinHTTPAuthScheme") = 1
client.ConnectorProperty("AuthUser") = Username
client.ConnectorProperty("AuthPassword") = Password
' ^^^^^^ New Authentication Method Supported with WC3.0 ^^^^^^
'************************************************************************** ***************************
'NOTE: To retieve ALL trend values from WebCTRL (for a given date range), set the following to True:
'************************************************************************** ***************************
'RetrieveAllTrends = False
RetrieveAllTrends = True
If (RetrieveAllTrends) Then
' vvvvvv New Authentication Method Supported with WC3.0 vvvvvv
GetTrendData = client.GetTrendData(TrendExpression, Format(StartDate, "mm/dd/yyyy hh:mm:ss AMPM"), Format(EndDate, "mm/dd/yyyy hh:mm:ss AMPM"), LimitFromStart, 0)
' ^^^^^^ New Authentication Method Supported with WC3.0 ^^^^^^
Else
' vvvvvv New Authentication Method Supported with WC3.0 vvvvvv
GetTrendData = client.GetTrendData(TrendExpression, Format(StartDate, "mm/dd/yyyy hh:mm:ss AMPM"), Format(EndDate, "mm/dd/yyyy hh:mm:ss AMPM"), LimitFromStart, MaxRecords)
' ^^^^^^ New Authentication Method Supported with WC3.0 ^^^^^^
End If
Exit Function
Exception:
Status.Font.ColorIndex = 3
'Debug.Print TrendExpression & " error: " & Err.Description
End Function
Public Function GetValue(ByVal Server As String, ByVal Username As String, ByVal Password As String, ByVal Expression As String, ByVal Status As Range) As String
On Error GoTo Exception
Dim client As MSSOAPLib30.SoapClient30
Set client = CreateObject("MSSOAP.SOAPClient30")
client.mssoapinit ("" & Server & "/_common/services/EvalService?wsdl")
Dim Error_Page As Worksheet
Set Error_Page = Worksheets("Error_Page")
GetValue = client.GetValue(Username, Password, Expression)
Exit Function
Exception:
Debug.Print "Error (GetValue): " & Err.Description
Status.Value = Err.Description
GetValue = ""
End Function
[/vba]
Here is my thought. I am not sure if this is possible, but its the only thing I could think of under this circumstance.
Perhaps the call to the database is failing for some reason, and never finishing that procedure. Hence not allowing the rest of the code to continue? If this could possibly be the case would there be any way to set a time out period for the call to the database, and say if it doesnt complete the call within "X" seconds it will cancel it and try it again?
Reply With Quote