In Access, I'm trying to create a table Field called "Signed Year" which has to be from 1970 to present (currently 1970-2018) using Lookup Wizard. However, I realised it's not optimal since I have to manually add one more year from time to time.
Is there a code of some sort to automatically generate such ranges?
Thanks a lot!
You can use a callback list for this. Here is code for one listing ultimo dates 15 years back:
Public Function ListUltimoYears( _
ctl As Control, _
lngId As Long, _
lngRow As Long, _
lngCol As Long, _
intCode As Integer) _
As Variant
' Period for listing dates.
Const cintYears As Integer = 15
' 2014-09-24. Cactus Data ApS, CPH.
Static datFirstDate As Date
Static strFormat As String
Static intRows As Integer
Dim datDate As Date
Dim varValue As Variant
Select Case intCode
Case acLBInitialize
datDate = Date
datFirstDate = DateSerial(Year(datDate), 12, 31)
intRows = 1 + cintYears
strFormat = ctl.Format
varValue = True ' True to initialize.
Case acLBOpen
varValue = Timer ' Autogenerated unique ID.
Case acLBGetRowCount ' Get rows.
varValue = intRows ' Set number of rows.
Case acLBGetColumnCount ' Get columns.
varValue = 1 ' Set number of columns.
Case acLBGetColumnWidth ' Get column width.
varValue = -1 ' Use default width.
Case acLBGetValue ' Get the data for each row.
varValue = DateAdd("yyyy", lngRow, datFirstDate)
Case acLBGetFormat ' Format the data.
varValue = strFormat ' Use format of control.
Case acLBEnd
' Do something when form with listbox closes or
' listbox is requeried.
End Select
' Return Value.
ListUltimoYears = varValue
End Function
Modify it from using:
Const cintYears As Integer = 15
to use a variable:
Dim intYears = DateDiff("yyyy", #1/1/1970#, Date)
To use it in a form, set the combobox' property RowSourceType: ListUltimoYears
Related
I'm trying to refine the below code /commented out/ to something like the shorter script at the bottom.
Using VBA6 as this is legacy code.
Private Sub XLSetCol(xc1, xc2, xc3, xc4, xc5, xc6, xc7, xc8, xc9, xc10, xc11, xc12, xc13, xc14, xc15)
' Column Width
'excel_app.Columns("A").ColumnWidth = xc1
' excel_app.Columns("B").ColumnWidth = xc2
' excel_app.Columns("C").ColumnWidth = xc3
' excel_app.Columns("D").ColumnWidth = xc4
' excel_app.Columns("E").ColumnWidth = xc5
' excel_app.Columns("F").ColumnWidth = xc6
' excel_app.Columns("G").ColumnWidth = xc7
' excel_app.Columns("H").ColumnWidth = xc8
' excel_app.Columns("I").ColumnWidth = xc9
' excel_app.Columns("J").ColumnWidth = xc10
' excel_app.Columns("K").ColumnWidth = xc11
' excel_app.Columns("L").ColumnWidth = xc12
' excel_app.Columns("M").ColumnWidth = xc13
' excel_app.Columns("N").ColumnWidth = xc14
' excel_app.Columns("O").ColumnWidth = xc15
The below code results in
"Runtime error '1004' Unable to set the ColumnWidth property of the Range Class.
For temp = 1 To 15
tempa = "ABCDEFGHIJKLMNO"
middle = Mid(tempa, temp, 1)
foo = ("xc" & temp)
excel_app.Columns(middle).ColumnWidth = foo
Next temp
End Sub
As mentioned in the comments a ParamArray would be one solution. You could also use just arrays.
The code below assumes that at some stage you may wish to use column Ids with more than one letter.
Option Explicit
'XLSetCol = "A,B,C,D,AF,BZ,DY", 10,10,10,20,30,40,40,40
Private Sub XLSetCol(ByVal ipColumns As String, ParamArray ipColWidths() As Variant)
' ipColumns is a list of comma separated column ids
' we use comma separated so we can have columsn such as 'df' etc
' also, it means the columns don't have to be consecutive
' you just need to match the column id's with the
' widths in the param array
Dim myColumns As Variant
myColumns = VBA.Split(ipColumns, ",")
Dim myIndex As Long
For myIndex = LBound(ipColWidths) To UBound(ipColWidths)
excel_app.Columns(myColumns(myIndex)).ColumnWidth = ipColWidths(myIndex)
Next
End Sub
' Or the dual array version
' XLSetcol Array("A","B","C","D"),Array(10,10,20,20,30))
Private Sub XLSetCol(ByRef ipColIds As Variant, ByRef ipColWidths As Variant)
Dim myIndex As Long
For myIndex = LBound(ipColIds) To UBound(ipColIds)
excel_app.Columns(ipColIds(myIndex)).ColumnWidth = ipColWidths(myIndex)
Next
End Sub
Please note that I haven't tested the above code. Bit it is useful as a pointer.
I receive weird numbers from a function in VBA.
I have Continuous Forms where is a button from which user can manipulate sum of hours in a text box. This text box is located in Form Footer.
My code goes like this:
Private Sub Option39_Click()
Dim time As Double
'calculate time to format
time = 25 / 24
If Option39.Value = True Then
Debug.Print dblTotal
dblTotal = dblTotal + time
Debug.Print dblTotal
Me.txtTotalTeamTotal = FormatUnlimitedHours(dblTotal)
Debug.Print dblTotal
Else
dblTotal = dblTotal - time
Me.txtTotalTeamTotal = FormatUnlimitedHours(dblTotal)
End If
End Sub
from debug.print i receive these values
3,66611111111111
4,70777777777778
112,986666666667
which I don't understand why the dblTotal change its value from 4,70777777777778 to 112,986666666667 Why was the number changed?
FormatUnlimitedHours() function is defined like this:
Public Function FormatUnlimitedHours(time As Variant) As Variant
'function that can have unlimited number of hours in hh:mm:ss format
Dim comma As Integer
Dim hours As Variant
Dim minutes As Variant
'switch to hours format
time = time * 24
If time > 23 Then
comma = InStr(time, ",") - 1
If Not comma < 0 Then
minutes = "0," & Mid(time, comma + 2, Len(time) - comma + 1)
minutes = format(minutes / 24, "hh:mm:ss")
hours = CDbl(Left(time, comma)) + CDbl(Left(minutes, InStr(minutes, ":") - 1))
FormatUnlimitedHours = hours & ":" & Mid(minutes, InStr(minutes, ":") + 1, 5)
Exit Function
Else
'for whole numbers
FormatUnlimitedHours = time & ":00:00"
Exit Function
End If
End If
FormatUnlimitedHours = format(time / 24, "hh:mm:ss")
End Function
initial value of dblTotal is defined when the form is loaded
Private Sub Form_Load()
dblTotal = DSum("sumOfTotalTime", "QueryTime")
End Sub
Tim Williams has answered your question. However, you should never handle date and time as anything else than DateTime. It only complicates matters.
For example, comma is not the decimal separator in most English speaking countries, and the "base" type of DateTime is Double, so normally it makes no difference to convert back and forth between DateTime and Double.
Here's an example of a similar function following these rules - which also makes it a lot simpler:
Public Function FormatHourMinuteSecond( _
ByVal datTime As Date, _
Optional ByVal strSeparator As String = ":") _
As String
' Returns count of days, hours, minutes, and seconds of datTime
' converted to hours, minutes, and seconds as a formatted string
' with an optional choice of time separator.
'
' Example:
' datTime: #10:03:55# + #20:01:24#
' returns: 30:05:19
'
' 2014-06-17. Cactus Data ApS, CPH.
Dim strHour As String
Dim strMinuteSec As String
Dim strHours As String
strHour = CStr(Fix(datTime) * 24 + Hour(datTime))
' Add leading zero to minute and second count when needed.
strMinuteSec = Right("0" & CStr(Minute(datTime)), 2) & strSeparator & Right("0" & CStr(Second(datTime)), 2)
strHours = strHour & strSeparator & strMinuteSec
FormatHourMinuteSecond = strHours
End Function
Example:
? FormatHourMinuteSecond(25 / 24)
25:00:00
My boss has asked me to modify his existing MS Access database. It pretty much consists of a few tables, a query and a form to show the query results.
We store the database in a central repository that can be accessed by all staff to use. He wants me to make it so when the file downloaded from the repository it will only last for 24 hours.
I've tried VBA to set a timer of 24 hours when the file is first opened and then the form checks every 5 seconds if the database has exceeded this timer. The timer resets every time the database is started up however, which means the database essentially does not have an expiry date/time as it can be reopened indefinitely. How do I solve this?
Form Code:
Public Sub Form_Load()
Call Database_Expiry_Assignment
Call Database_Expiry_Check
End Sub
Private Sub Form_Timer()
Call Database_Expiry_Check
End Sub
Module Code:
Option Compare Database
Global Database_Expiry As Variant
Public Sub Database_Expiry_Assignment()
Database_Expiry = Now() + TimeSerial(24, 0, 0)
MsgBox ("Database_Expiry_Timestamp: " & Database_Expiry)
End Sub
Public Function Database_Expiry_Check()
On Error GoTo ErrHandler:
If (Database_Expiry <= Now()) Then
MsgBox "Referral Database is out of date." & vbCrLf & vbCrLf & _
"Please download the" & vbCrLf & _
"latest version.", vbInformation + vbOKOnly, "Database Expired!"
DoCmd.Quit
End If
Exit_ErrHandler:
Exit Function
ErrHandler:
MsgBox Err.Description, vbCritical
Err.Clear
End Function
This is exactly what I do in my project VBA.CurrencyCode
Study the use of UpdatePause and IsCurrent in module Cca.bas:
Attribute VB_Name = "Cca"
Option Compare Database
Option Explicit
' CurrencyCode V1.1.1
' (c) Gustav Brock, Cactus Data ApS, CPH
' https://github.com/GustavBrock/VBA.CurrencyCode
' API id or key. Guid string, 0, 24, or 32 characters.
'
' Currency Converter API: "00000000-0000-0000-0000-000000000000"
' Leave empty for the free plan: ""
Public Const CcaApiId As String = ""
' Enums.
'
' Dimensions of array holding parameters.
Private Enum ParameterDetail
Name = 0
Value = 1
End Enum
'
' Dimensions of array holding codes.
Private Enum CodeDetail
Code = 0
Sign = 1
Name = 2
End Enum
'
' HTTP status codes, reduced.
Private Enum HttpStatus
OK = 200
BadRequest = 400
Unauthorized = 401
Forbidden = 403
End Enum
' Currency code for neutral currency.
Public Const NeutralCode As String = "XXX"
' Currency name for neutral currency.
Public Const NeutralName As String = "No currency"
' Currency sign for neutral currency.
Public Const NeutralSign As String = "ยค"
' Retrieve the current currency code list from Currency Converter API.
' The list is returned as an array and cached until the next update.
'
' Source:
' https://currencyconverterapi.com/
' https://currencyconverterapi.com/docs
'
' Note:
' The services are provided as is and without warranty.
'
' Example:
' Dim Codes As Variant
' Codes = ExchangeRatesCca()
' Codes(101, 0) -> CHF ' Currency code.
' Codes(101, 1) -> "Fr." ' Currency name.
' Codes(101, 2) -> "Swiss Franc" ' Currency name.
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyCodesCca() As Variant
' Operational constants.
'
' API endpoint.
Const FreeSubdomain As String = "free"
Const PaidSubdomain As String = "api"
Const TempSubdomain As String = "xxx"
' API version must be 3 or higher.
Const ApiVersion As String = "6"
Const ServiceUrl As String = "https://" & TempSubdomain & ".currencyconverterapi.com/api/v" & ApiVersion & "/currencies"
' Update interval in minutes.
Const UpdatePause As Integer = 24 * 60
' Function constants.
'
' Node names in retrieved collection.
Const RootNodeName As String = "root"
Const ListNodeName As String = "results"
' ResponseText when invalid currency code is passed.
Const EmptyResponse As String = "{}"
' Field names.
Const CodeId As String = "id"
Const CodeName As String = "currencyName"
Const CodeSymbol As String = "currencySymbol"
Static CodePairs As Collection
Static Codes() As Variant
Static LastCall As Date
Dim DataCollection As Collection
Dim CodeCollection As Collection
Dim Parameter() As String
Dim Parameters() As String
Dim UrlParts(1) As String
Dim Subdomain As String
Dim CodeCount As Integer
Dim Index As Integer
Dim Item As Integer
Dim Value As String
Dim FieldCount As Integer
Dim Url As String
Dim ResponseText As String
Dim ValueDate As Date
Dim ThisCall As Date
Dim IsCurrent As Boolean
' Is the current collection of Codes up-to-date?
IsCurrent = DateDiff("n", LastCall, Now) < UpdatePause
If IsCurrent Then
' Return cached codes.
Else
' Retrieve the code pair and add it to the collection of code pairs.
' Set subdomain to call.
If CcaApiId = "" Then
' Free plan is used.
Subdomain = FreeSubdomain
Else
' Paid plan is used.
Subdomain = PaidSubdomain
End If
' Define parameter array.
' Redim for two dimensions: name, value.
ReDim Parameter(0 To 0, 0 To 1)
' Parameter names.
Parameter(0, ParameterDetail.Name) = "apiKey"
' Parameter values.
Parameter(0, ParameterDetail.Value) = CcaApiId
' Assemble parameters.
ReDim Parameters(LBound(Parameter, 1) To UBound(Parameter, 1))
For Index = LBound(Parameters) To UBound(Parameters)
Parameters(Index) = Parameter(Index, 0) & "=" & Parameter(Index, 1)
Next
' Assemble URL.
UrlParts(0) = Replace(ServiceUrl, TempSubdomain, Subdomain)
UrlParts(1) = Join(Parameters, "&")
Url = Join(UrlParts, "?")
' Uncomment for debugging.
Debug.Print Url
' Define a no-result array.
' Redim for three dimensions: code, symbol, name.
ReDim Codes(0, 0 To 2)
' Set "not found" return values.
Codes(0, CodeDetail.Code) = NeutralCode
Codes(0, CodeDetail.Name) = NeutralName
Codes(0, CodeDetail.Sign) = NeutralSign
If RetrieveDataResponse(Url, ResponseText) = True Then
Set DataCollection = CollectJson(ResponseText)
End If
If DataCollection Is Nothing Then
' Error. ResponseText holds the error code.
' Optional error handling.
Select Case ResponseText
Case HttpStatus.BadRequest
' Typical for invalid api key, or API limit reached.
Case EmptyResponse
' Invalid currency code.
Case Else
' Other error.
End Select
End If
If Not DataCollection Is Nothing Then
If DataCollection(RootNodeName)(CollectionItem.Data)(1)(CollectionItem.Name) = ListNodeName Then
' The code list was retrieved.
' Get count of codes.
CodeCount = DataCollection(RootNodeName)(CollectionItem.Data)(ListNodeName)(CollectionItem.Data).Count
ReDim Codes(0 To CodeCount - 1, 0 To 2)
For Index = 1 To CodeCount
' The code information is a collection.
Set CodeCollection = DataCollection(RootNodeName)(CollectionItem.Data)(1)(CollectionItem.Data)(Index)(CollectionItem.Data)
FieldCount = CodeCollection.Count
' Fill one array item.
For Item = 1 To FieldCount
Value = CodeCollection(Item)(CollectionItem.Data)
Select Case CodeCollection(Item)(CollectionItem.Name)
Case CodeId
Codes(Index - 1, CodeDetail.Code) = Value
Case CodeName
Codes(Index - 1, CodeDetail.Name) = Value
Case CodeSymbol
Codes(Index - 1, CodeDetail.Sign) = Value
End Select
Next
Next
' Round the call time down to the start of the update interval.
ThisCall = CDate(Fix(Now * 24 * 60 / UpdatePause) / (24 * 60 / UpdatePause))
' Record hour of retrieval.
LastCall = ThisCall
End If
End If
End If
CurrencyCodesCca = Codes
End Function
' Retrieve and update the table holding the list of currency codes
' published by Currency Code API.
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function UpdateCurrencyCodes() As Boolean
' Table and field names of table holding currency codes.
Const TableName As String = "CurrencyCode"
Const Field1 As String = "Code"
Const Field2 As String = "Name"
Const Field3 As String = "Symbol"
Const Field4 As String = "Assigned"
Const Field5 As String = "Unassigned"
Dim Records As DAO.Recordset
Dim Codes As Variant
Dim Item As Integer
Dim Sql As String
Dim Criteria As String
Dim Unassigned As Boolean
On Error GoTo Err_UpdateCurrencyCodes
' Retrieve array of current currency codes.
Codes = CurrencyCodesCca
Sql = "Select * From " & TableName & ""
Set Records = CurrentDb.OpenRecordset(Sql)
' Add new currency codes.
For Item = LBound(Codes, 1) To UBound(Codes, 1)
Criteria = "Code = '" & Codes(Item, CodeDetail.Code) & "'"
Records.FindFirst Criteria
If Records.NoMatch Then
' New currency code.
Records.AddNew
Records.Fields(Field1).Value = Codes(Item, CodeDetail.Code)
Records.Fields(Field2).Value = Codes(Item, CodeDetail.Name)
Records.Fields(Field3).Value = Codes(Item, CodeDetail.Sign)
Records.Fields(Field4).Value = Date
Records.Update
ElseIf Not IsNull(Records.Fields(Field5).Value) Then
' Existing currency code, marked as unassigned.
' Reassign.
Records.Edit
Records.Fields(Field4).Value = Date
Records.Fields(Field5).Value = Null
Records.Update
End If
Next
' Mark retracted currency codes as unassigned.
Records.MoveFirst
While Not Records.EOF
Unassigned = True
For Item = LBound(Codes, 1) To UBound(Codes, 1)
If Records.Fields("Code").Value = Codes(Item, CodeDetail.Code) Then
Unassigned = False
Exit For
End If
Next
If Unassigned Then
Records.Edit
Records.Fields("Unassigned").Value = Date
Records.Update
End If
Records.MoveNext
Wend
Records.Close
UpdateCurrencyCodes = True
Exit_UpdateCurrencyCodes:
Exit Function
Err_UpdateCurrencyCodes:
MsgBox "Error" & Str(Err.Number) & ": " & Err.Description, vbCritical + vbOKOnly, "Update Currency Codes"
Resume Exit_UpdateCurrencyCodes
End Function
' Check if a currency code is one of the listed currency codes
' published by Currency Code API.
'
' 2018-09-24. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function IsCurrencyCode( _
ByVal Code As String) _
As Boolean
' Table (or query) and field names of table holding currency codes.
Const TableName As String = "CcaCurrencyCode"
Const Field1 As String = "Code"
Dim Criteria As String
Dim Result As Boolean
Criteria = Field1 & " = '" & Code & "'"
Result = Not IsNull(DLookup(Field1, TableName, Criteria))
IsCurrencyCode = Result
End Function
Firstly, here's a pic on my report in design mode:
The underlying query for the report returns values like so:
Allen Nelli 3:A,5:B,7:A,8:A, etc.
Breton Micheline 1:A,3:A,5:B,7:A, etc
Caporale Jody 1:A,3:A,5:B,7:A, etc
I had to use a subquery to get the third field which concatenates the number : letter combinations. These values actually represent day of month and designation to a particular shift in a schedule. So basically, for a given month, each individual works the designated shift indicated by the day value.
The intention is to call a user defined public function named PopulateTextboxes(Value as String) to be called from the first textbox in the report from the textbox's ControlSource property. The third field in the query is actually named Expr1 and that is being passed as a parameter to the function. The function is designed to populate all the textboxes with the appropriate letter designation: A or B or C or D, etc. The function itself is not being fired when I run the report.
The function is as follows:
Public Function PopulateTextboxes(Expr As String) As String
'Each element of Expr should be a number followed by a colon followed by a letter: 10:A,12:B,15:C, etc.
Dim shiftData() As String
Dim Data As Variant
Dim i As Integer
Dim j As Integer
Dim temp() As String
Dim txt As TextBox
Dim rpt As Report
Dim strCtrl As String
If Expr = "" Then Exit Function
If IsNull(Expr) Then Exit Function
shiftData = Split(Expr, ",")
If UBound(shiftData) > 0 Then
'Make a 2D array
ReDim Data(UBound(shiftData), 2)
'Load up 2D array
For i = 0 To UBound(shiftData) - 1
If shiftData(i) <> "" Then
temp = SplitElement(shiftData(i), ":")
Data(i, 0) = temp(0)
Data(i, 1) = temp(1)
End If
Next i
Set rpt = Reports.item("Multi_Locations_Part_1")
If UBound(days) = 0 Then
MsgBox "days array not populated"
Exit Function
End If
'Populate each Textbox in the Multi_Locations_Part_1 Report
For i = 1 To UBound(days)
strCtrl = "txtDesig_" & CStr(i)
Set txt = rpt.Controls.item(strCtrl)
For j = 0 To UBound(Data) - 1
If Data(j, 0) = days(i) Then
txt.Value = Data(j, 1) 'A,B,C,etc.
Exit For
End If
Next j
Next i
End If
PopulateTextboxes = Expr
End Function
Private Function SplitElement(Value As String, Delim As String) As String()
Dim result() As String
result = Split(Value, Delim)
SplitElement = result
End Function
Please advise.
The best way is to call your function from the Format event of the Detail section, so it will be called for each record.
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Call PopulateTextboxes(Me.Expr1)
End Sub
If PopulateTextboxes is in a separate module, I suggest to pass Me as additional parameter for the report, so you don't have to hardcode the report name.
Also note that you need the Set keyword when assigning object variables, e.g.
Set txt = rpt.Controls.item("txtDesig_" & CStr(i))
I am trying to implement millisecond timestamping in Access 2010/13 using this method;
MS Access Can Handle Millisecond Time Values--Really - See more at: http://www.devx.com/dbzone/Article/39046#sthash.xEIruMyE.dpuf
The function Msec(2) is supposed to return the system time in milliseconds but it seems to be about 10 hours out.
Public Function Msec( _
Optional ByVal intTimePart As Integer) _
As Date
' This is the core function.
' It generates the current time with millisecond resolution.
'
' Returns current (local) date/time including millisecond.
' Parameter intTimePart determines level of returned value:
' 0: Millisecond value only.
' 1: Time value only including milliseconds.
' 2: Full Date/time value including milliseconds.
' None or any other value: Millisecond value only.
Const cintMsecOnly As Integer = 0
Const cintMsecTime As Integer = 1
Const cintMsecDate As Integer = 2
Static typTime As SYSTEMTIME
Static lngMsecInit As Long
Dim datMsec As Date
Dim datDate As Date
Dim intMilliseconds As Integer
Dim lngTimeZoneBias As Long
Dim lngMsec As Long
Dim lngMsecCurrent As Long
Dim lngMsecOffset As Long
' Set resolution of timer to 1 ms.
timeBeginPeriod 1
lngMsecCurrent = timeGetTime()
If lngMsecInit = 0 Or lngMsecCurrent < lngMsecInit Then
' Initialize.
' Get bias for local time zone respecting
' current setting for daylight savings.
lngTimeZoneBias = GetLocalTimeZoneBias(False)
' Get current UTC system time.
Call GetSystemTime(typTime)
intMilliseconds = typTime.wMilliseconds
' Repeat until GetSystemTime retrieves next count of milliseconds.
' Then retrieve and store count of milliseconds from launch.
Do
Call GetSystemTime(typTime)
Loop Until typTime.wMilliseconds <> intMilliseconds
lngMsecInit = timeGetTime()
' Adjust UTC to local system time by correcting for time zone bias.
typTime.wMinute = typTime.wMinute - lngTimeZoneBias
' Note: typTime may now contain an invalid (zero or negative) minute count.
' However, the minute count is acceptable by TimeSerial().
Else
' Retrieve offset from initial time to current time.
lngMsecOffset = lngMsecCurrent - lngMsecInit
End If
With typTime
' Now, current system time is initial system time corrected for
' time zone bias.
lngMsec = (.wMilliseconds + lngMsecOffset)
Select Case intTimePart
Case cintMsecTime, cintMsecDate
' Calculate the time to add as a date/time value with millisecond resolution.
datMsec = lngMsec / 1000 / clngSecondsPerDay
' Add to this the current system time.
datDate = datMsec + TimeSerial(.wHour, .wMinute, .wSecond)
If intTimePart = cintMsecDate Then
' Add to this the current system date.
datDate = datDate + DateSerial(.wYear, .wMonth, .wDay)
End If
Case Else
' Calculate millisecond part as a date/time value with millisecond resolution.
datMsec = (lngMsec Mod 1000) / 1000 / clngSecondsPerDay
' Return millisecond part only.
datDate = datMsec
End Select
End With
Msec = datDate
End Function
As Jack hardcastle says; Probably Timezone related.
It never runs this code;
If lngMsecInit = 0 Or lngMsecCurrent < lngMsecInit Then
' Initialize.
' Get bias for local time zone respecting
' current setting for daylight savings.
lngTimeZoneBias = GetLocalTimeZoneBias(False)
' Get current UTC system time.
Call GetSystemTime(typTime)
intMilliseconds = typTime.wMilliseconds
' Repeat until GetSystemTime retrieves next count of milliseconds.
' Then retrieve and store count of milliseconds from launch.
Do
Call GetSystemTime(typTime)
Loop Until typTime.wMilliseconds <> intMilliseconds
lngMsecInit = timeGetTime()
' Adjust UTC to local system time by correcting for time zone bias.
typTime.wMinute = typTime.wMinute - lngTimeZoneBias
' Note: typTime may now contain an invalid (zero or negative) minute count.
' However, the minute count is acceptable by TimeSerial().
But goes to;
Else
' Retrieve offset from initial time to current time.
lngMsecOffset = lngMsecCurrent - lngMsecInit
End If
Answer! From #pathDongle
Time is stored as Millisecond UTC;
!DateTimeMS = GetTimeUTC()
And restored by;
Public Function UTCtoTimeLocal(dSysUTC As Date) As Date
'Dim sysTime As SYSTEMTIME
Dim DST As Long
Dim tzi As TIME_ZONE_INFORMATION
DST = GetTimeZoneInformation(tzi)
UTCtoTimeLocal = dSysUTC - TimeSerial(0, tzi.Bias, 0) + IIf(DST = 2, TimeSerial(1, 0, 0), 0)
End Function
Query;
SELECT tblzzAuditTrail.DateTimeMS, FormatDate(UTCtoTimeLocal([DateTimeMS])) AS DateTimeLocal
Which can be filtered on as a String.
Private Sub BuildFilter()
Dim strFilter As String
Dim ctl As Control
strFilter = ""
'add selected values to string
For Each ctl In Me.FormHeader.Controls
With ctl
If .ControlType = acTextBox Or .ControlType = acComboBox Then
If Nz(.Value) <> "" Then
If InStr(.Name, "Date") <> 0 Then
If Nz(StartDate) <> "" And Nz(EndDate) <> "" And InStr(strFilter, "DateTimeLocal") = 0 Then
strFilter = strFilter & "[DateTimeLocal] BETWEEN '" & FormatDate(Me.StartDate.Value) & "' AND '" & FormatDate(Me.EndDate.Value) & "' AND "
ElseIf Nz(StartDate) <> "" And InStr(strFilter, "DateTimeLocal") = 0 Then
strFilter = strFilter & "[DateTimeLocal] > '" & FormatDate(Me.StartDate.Value) & "' AND "
ElseIf Nz(EndDate) <> "" And InStr(strFilter, "DateTimeLocal") = 0 Then
strFilter = strFilter & "[DateTimeLocal] <= '" & FormatDate(Me.EndDate.Value) & "' AND "
End If
ElseIf InStr(.Name, "ID") <> 0 Then
strFilter = strFilter & "[" & .Name & "] = " & .Value & " AND "
Else
strFilter = strFilter & "[" & .Name & "] = '" & .Value & "' AND "
End If
End If
End If
End With
Next ctl
'trim trailing And
strFilter = TrimR(strFilter, 5)
Debug.Print strFilter
With Me.subfrmzzAuditTrailDisplay
.Form.Filter = strFilter
.Form.FilterOn = True
End With
End Sub
Resulting Filter String;
[UserID] = 2 AND [DateTimeLocal] BETWEEN '06/01/2015 00:00:00.000' AND '07/01/2015 00:00:00.000'
As per my other question;
Millisecond time: Filter form by date
Most of those functions can be simplified down to the following:
Function GetTimeLocal will return the users local system datetime with daylight saving adjustment
Function GetTimeUTC will return UTC time
Function FormatDate will format a Date as a string with the correct millisecond component.
Usually it's better to store all times as UTC and convert if needed.
Option Explicit
#If Win64 Then
Public Declare PtrSafe Sub GetSystemTime Lib "kernel32" (ByRef lpSystemTime As SYSTEMTIME)
Private Declare PtrSafe Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
#Else
Public Declare Sub GetSystemTime Lib "kernel32" (ByRef lpSystemTime As SYSTEMTIME)
Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
#End If
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(31) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(31) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Sub test()
Dim dtLcl As Date
Dim dtUTC As Date
dtLcl = GetTimeLocal 'Gets local time including adjustement for daylight saving time
dtUTC = GetTimeUTC 'Gets UTC time
Debug.Print FormatDate(dtLcl)
Debug.Print FormatDate(dtUTC)
End Sub
Function FormatDate(ByVal dt As Date) As String
Dim sysTime As SYSTEMTIME
Dim sec As Double
Dim x As Double
With sysTime
.wYear = Year(dt)
.wMonth = Month(dt)
.wDay = Day(dt)
.wHour = Hour(dt)
.wMinute = Minute(dt)
'Second() function rounds to nearest second so calc floor second
'Eg 12:15:09.678 will give second component as 10 instead of 09
x = (dt - Int(dt)) * 86400#
sec = x - Fix(x / 60#) * 60#
.wSecond = Int(sec)
.wMilliseconds = Int(Round(sec - .wSecond, 3) * 1000)
FormatDate = Format(dt, "dd/mm/yyyy hh:mm:ss.") & Format(sysTime.wMilliseconds, "000")
End With
End Function
Public Function GetTimeLocal() As Date
Dim dSysUTC As Date, sysTime As SYSTEMTIME
Dim DST As Long, IsDST As Boolean
Dim tzi As TIME_ZONE_INFORMATION
Dim ms As Double
GetSystemTime sysTime
With sysTime
'Debug.Print "ms=" & .wMilliseconds
ms = CDbl(.wMilliseconds) / (86400# * 1000#)
dSysUTC = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond) + ms
End With
DST = GetTimeZoneInformation(tzi)
GetTimeLocal = dSysUTC - TimeSerial(0, tzi.Bias, 0) + IIf(DST = 2, TimeSerial(1, 0, 0), 0)
End Function
Public Function GetTimeUTC() As Date
Dim dSysUTC As Date
Dim sysTime As SYSTEMTIME
Dim ms As Double
GetSystemTime sysTime
With sysTime
'Debug.Print "ms=" & .wMilliseconds
ms = CDbl(.wMilliseconds) / (86400# * 1000#)
GetTimeUTC = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond) + ms
End With
End Function