I just want to calculate the time that Dijkstra function will take to calculate shortest path for source node as the network nodes are in Q
Do While True
Dim dist As Integer = Integer.MaxValue
For i = 1 To Q.Count
If Q.Item(i).dist < dist Then
dist = Q.Item(i).dist
u = Q.Item(i)
End If
Next i
If dist = Integer.MaxValue Then Exit Do 'no more nodes available - done!
Q.Remove(u.name_t)
'loop over neighbors of u that are in Q
For j = 1 To Q.Count
For Each train In trains
If train.src.name_t = u.name_t And train.dst.name_t = Q.Item(j).name_t Then
alt = u.dist + train.t
If alt < Q.Item(j).dist Then
Q.Item(j).dist = alt
Q.Item(j).prev = u
End If
End If
Next
Next
Loop
try with this
Dim starttime As DateTime
Dim endtime As DateTime
Dim elapsed As Double
starttime = Format(Now(), "hh:mm:ss") 'beginning
'your code here
endtime = Format(Now(), "hh:mm:ss") 'end
Elapsed = DateDiff("s", starttime, endtime)
MsgBox("Finished in " & Elapsed & " seconds")
**EDIT 2 **
Sub time()
startTime = Timer
endtime = Timer
totalTime = Format(finishTime - startTime, "ss")
End Sub
Get the system date-time before and after function execution, then calculate the difference.
Related
Global time As Date
Sub countdown()
time = Now()
time = DateAdd("s", 120, time)
Do Until time < Now()
DoEvents
oSh.TextFrame.TextRange = Format((time - Now()), "ss")
Loop
End Sub
The timer starts from 60 and ends at 00. Then the same repeats. Is it possible to start the timer from 120 directly? How can we go about it?
Use DateDiff:
Global StopTime As Date
Sub countdown()
StopTime = DateAdd("s", 120, Now)
Do Until StopTime < Now
DoEvents
oSh.TextFrame.TextRange = DateDiff("s", Now, StopTime)
Loop
End Sub
Format will simply read the seconds from a date value, there is no way to "force" it to calculate the total seconds. However, it is rather easy to calculate it manually:
Dim delta as Date
delta = t - now
oSh.TextFrame.TextRange = Minute(d) * 60 + Second(d)
' or, if you want to have always 3 digits, eg 030
oSh.TextFrame.TextRange = Format(Minute(d) * 60 + Second(d), "000")
I have a many to many relationship between two entities. Computer and Booking, with the link entity being BookingToComputer which contains bookingID and computerID. Im trying to check that the computer is available for booking before adding it to the tables.
So I've selected the date, time, and hours of use (3 attributes in the booking table) of existing Booking records. I've created two time variable, start time (totalTime) and the end time of a booking (endtime). I've tried to put a loop to where each item in my list would go through all the selected rows from a datagridview to check if they match but I don't think I got it quite right and at this point im super confused.
Dim Part1 As String = txtTime.Text + ":00:00"
Dim Part2 As String = "00:" + txtTime1.Text + ":00"
Dim Part3 As String = "00:00:" + txtTime2.Text
Dim Time1 As TimeSpan = TimeSpan.Parse(Part1)
Dim Time2 As TimeSpan = TimeSpan.Parse(Part2)
Dim Time3 As TimeSpan = TimeSpan.Parse(Part3)
Dim TotalTime As TimeSpan = Time1 + Time2 + Time3
SQL.AddParam("#Time", txtTime.Text & ":" & txtTime1.Text & ":" & txtTime2.Text)
SQL.AddParam("#Date", txtDate.Text)
SQL.ExecQuery("SELECT bc.Computer_ID, hours_of_use, time_of_use FROM BookingToComputer AS bc, Computer AS c, Booking AS b
WHERE bc.Booking_ID = b.Booking_ID AND c.Computer_ID = bc.Computer_ID AND b.date_of_use = #Date AND b.time_of_use <= #Time;")
DataGridView2.DataSource = SQL.DBDT
If DataGridView2.Rows.Count() > 0 Then
'cell1 contains the hours used and time contains the time'
Dim TimeInt As Integer = DataGridView2.Rows(0).Cells(1).Value
Dim TimeInt2 As TimeSpan = DataGridView2.Rows(0).Cells(2).Value
Dim Addit As String = TimeInt.ToString + ":00:00"
Dim interv As TimeSpan = TimeSpan.Parse(Addit)
Dim endtime As TimeSpan = TimeInt2 + interv
Dim rowpass As Integer = 0
For Each x In listpick
Dim CompID As Integer = DataGridView2.Rows(rowpass).Cells(0).Value
If x = CompID Then
If endtime > TotalTime Then
MsgBox(x & " is already reserved.")
Else
MsgBox("diff time, same comp")
End If
Else
MsgBox("Good time - diff comp")
End If
rowpass = rowpass + 1
Next
End If
I used DoEvents to provide a 1 second delay in the VBA execution, to display the countdown in timer properly.
The code used was:
time2 = Now + TimeValue("00:00:01")
Do Until Now >= time2
DoEvents
Loop
I used the above code within another Do Until Loop. The code is showing the countdown, but the delay between each time slightly varies especially for the part displayed within the nested Do Until Loop!!
The rest of the code is:
Sub btnStart_Click()
Dim time_2 As Variant
g_position = True
If g_position = True Then
UserForm1.StartUpPosition = 0
UserForm1.Left = Application.Left + 0.5 * Application.Width + UserForm1.Width + 72
UserForm1.Top = Application.Top + (0.5 * Application.Height) - (UserForm1.Height) - 36
End If
start = Now
timeEnd = start + TimeValue("00:00:10")
g_start = Format(start, "hh:mm:ss")
g_timeEnd = Format(timeEnd, "hh:mm:ss")
time_duration = timeEnd - start
g_time_duration = Format(time_duration, "hh:mm:ss")
Label1.Visible = True
time_left.Caption = g_time_duration
time_left.Visible = True
btnStart.Visible = False
time_2 = Now + TimeValue("00:00:01")
Do Until Now >= time_2
DoEvents
Loop
g_temp = Format(temp, "hh:mm:ss")
etime = start + TimeValue("00:00:01")
time_duration = timeEnd - etime
g_time_duration = Format(time_duration, "hh:mm:ss")
time_left.Caption = g_time_duration
time_2 = Now + TimeValue("00:00:01")
Do Until Now >= time_2
DoEvents
Loop
Call modtimer.time_count(time_duration, etime, timeEnd, g_time_duration)
End Sub
The Module Code:
Sub time_count(time_duratn As Variant, etim As Variant, timEnd As Variant, g_time_duratn As Variant)
temp_end = Format(TimeValue("00:00:00"), "hh:mm:ss")
temp_alert = Format(TimeValue("00:00:05"), "hh:mm:ss")
etim = etim + TimeValue("00:00:01")
time_duratn = timEnd - etim
g_time_duratn = Format(time_duratn, "hh:mm:ss")
UserForm1.time_left.Caption = g_time_duratn
time2 = Now + TimeValue("00:00:01")
Do Until Now >= time2
DoEvents
Loop
Do Until g_time_duratn = temp_end
If g_time_duratn = temp_alert Then
Beep
MsgBox "Only 5 minutes remaining", vbInformation
End If
etim = etim + TimeValue("00:00:01")
time_duratn = timEnd - etim
g_time_duratn = Format(time_duratn, "hh:mm:ss")
UserForm1.time_left.Caption = g_time_duratn
time2 = Now + TimeValue("00:00:01")
Do Until Now >= time2
DoEvents
Loop
Loop
End_Exam
End Sub
Why is the delay in the countdown varying? Can anybody help?
You are getting different time spans because Now, as far as I tested, as 1 second resolution in Office VBA. So, Now will always round time to last second.
Eg, you start waiting at 00:00:00.500, Now will return #00:00:00#. When time reach 00:00:01.000, Now will return #00:00:01#, so you think you get 1 second delay, but it was just 0.5! Using Now you may "measure" 1 second time delays which may vary between 0 to 1 second!
As workaround, WinAPI GetLocalTime may be used to get 1 milisecond resolution timestamps:
Private Declare Sub GetLocalTime Lib "Kernel32" (lpSystemTime As Any)
Function Now_ms() As Date
Dim st(0 To 7) As Integer
GetLocalTime st(0)
Now_ms = DateSerial(st(0), st(1), st(3)) + TimeSerial(st(4), st(5), st(6)) + st(7) / 1000# * #12:00:01 AM#
End Function
Replace Now with Now_ms, which is full compatible with Date data type and returns a better resolution timestamp (1ms).
Better resolution timestamps can be achieved using GetSystemTimePreciseAsFileTime (0.1μs) or QueryPerformanceCounter.
Found a function on Excelguru which I changed a few things in and gonna edit some more. The idea is to use this to register worked hours and minutes.
There is one thing in this I don't understand: if I type the wrong time in the column reff I get a msg that its wrong, but it wont disappear unless I click it 10 times. I cant see what Im doing wrong. The entire code is posted and Im grateful for any help.
Use his function as part of the formula in the sheet like: TimeValue($E2;$F2;"16:00";"18:00";B2;9;C2)
Function TimeValue(FromTime As String, ToTime As String, StartTime As String, StopTime As String, Optional Weekday As String, Optional Daynr As Integer, Optional Holiday As String)
Dim x As Long
Dim F As Double
Dim T As Double
Dim Start As Double
Dim Stopp As Double
Dim Min As Long
Dim Day As Integer
Dim OverMid As Boolean
Select Case LCase(Weekday)
Case "mandag"
Day = 1
Case "tirsdag"
Day = 2
Case "onsdag"
Day = 3
Case "torsdag"
Day = 4
Case "fredag"
Day = 5
Case "lordag"
Day = 6
Case "sondag"
Day = 7
Case "x"
Day = 8
Case Else
Day = 0
End Select
OverMid = False
If LCase(Holiday) = "x" Then Day = 8
If Len(FromTime) = 0 Or Len(ToTime) = 0 Then
Exit Function
End If
If Len(FromTime) <> 5 Then
MsgBox ("Use format TT:MM - From time is wrong:" & FromTime)
Exit Function
End If
If Len(ToTime) <> 5 Then
MsgBox ("Use format TT:MM - To time is wrong:" & ToTime)
Exit Function
End If
F = Val(Left(FromTime, 2)) * 60 + Val(Right(FromTime, 2))
T = Val(Left(ToTime, 2)) * 60 + Val(Right(ToTime, 2))
Start = Val(Left(StartTime, 2)) * 60 + Val(Right(StartTime, 2))
Stopp = Val(Left(StopTime, 2)) * 60 + Val(Right(StopTime, 2))
If T = 0 Then T = 24 * 60
If T < F Then
T = T + 24 * 60
OverMid = True
End If
If Stopp = 0 Then Stopp = 24 * 60
For x = F + 1 To T
If x > Start And x <= Stopp Then
Min = Min + 1
End If
Next x
If OverMid = True Then
For x = 0 To Val(Left(ToTime, 2)) * 60 + Val(Right(ToTime, 2))
If x > Start And x <= Stopp Then
Min = Min + 1
End If
Next x
End If
'If weekday is set, equal to day
If Daynr <> 0 Then
If Daynr <> 9 Then
If Day <> Daynr Then Min = 0
End If
If Daynr = 9 And (Day > 5) Then
Min = 0
End If
End If
TimeValue = Min / 60
End Function
And the sub in the sheets
Private Sub Worksheet_Change(ByVal Target As Range)
Dim streng As String
Dim k As Long
Dim r As Long
k = Target.Column
r = Target.Row
If Cells(1, k) = "P" Then
If Cells(r, k) = "x" Then
Cells(r, 4) = "x"
Else
Cells(r, 4) = ""
End If
End If
End Sub
Message boxes really don't belong in UDFs (VBA functions meant to be used as spreadsheet functions).
Instead of the message box you could use code like:
If Len(FromTime) <> 5 Then
TimeValue = "Error! Use format TT:MM - From time is wrong:" & FromTime
Exit Function
Or perhaps:
If Len(FromTime) <> 5 Then
TimeValue = CVErr(xlErrValue)
Exit Function
This later will cause #VALUE! to display in the cell. Include enough documentation in your spreadsheet so that users can interpret such error values.
I have a code that gets an ETA (estimated time of arrival) but I want it to exclude weekends. I also have it to change the ETA if its past 2:30PM.
Code:
Dim ETA1 As Date = Date.Today.AddDays(1)
Dim ETA2 As Date = Date.Today.AddDays(2)
Dim ETA3 As Date = Date.Today.AddDays(3)
Dim day As String = Format(Today, "dddd")
Dim time As Date
Dim CurrHour As Integer
Dim CurrMinute As Integer
time = DateTime.Now
CurrHour = time.Hour
CurrMinute = time.Minute
If StoreBox.Text Like "25*" Then
MicroLabel.Visible = True
If CurrHour >= 2 AndAlso CurrMinute >= 30 Then
ETABox.Text = ETA2
Else
ETABox.Text = ETA1
End If
Else
MicroLabel.Visible = False
If CurrHour >= 2 AndAlso CurrMinute >= 30 Then
ETABox.Text = ETA2
Else
ETABox.Text = ETA1
End If
End If
DateTime is a very flexible type which allows you to easily perform many date/time related actions. You don't need to perform a string-like analysis (what your code is doing).
For example, to take care of the two requested functionalities, just do something like:
Dim curTime As DateTime = Now
Dim goAhead As Boolean = True
If curTime.DayOfWeek = DayOfWeek.Saturday OrElse curTime.DayOfWeek = DayOfWeek.Sunday Then
goAhead = False
ElseIf curTime > New DateTime(curTime.Year, curTime.Month, curTime.Day, 14, 30, 0) Then
goAhead = False
End If
If goAhead Then
'Weekday before 2:30 PM
End If