I have one field named "Date_Capture" created on the access form which is available for end user to select the date by using date picker. When user is selecting the date using date picker then only date is coming correct but the correct time is not showing up. for each record time is coming like 11/10/2015 12:00:00 AM, 11//11/2016 12:00:00 AM.I need to show the exact time when we select a particular date using date picker.
is there any work around to fix this? Please let me know.
Thanks,
RR
It is usually faster just to type the time, for example as described here:
Entering 24-hour time with input mask and full validation in Microsoft Access
with full code also here at GitHub.
You can enter dates much the same way:
Entering ISO formatted date with input mask and full validation in Microsoft Access
and code is here at GitHub.
Code:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Form_LogonDate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
Dim DefaultDate As Date
Dim DefaultFormat As String
Dim DefaultInputMask As String
Private Sub Form_Error(DataErr As Integer, Response As Integer)
Dim ctl As Control
Dim SelStart As Integer
On Error Resume Next
Set ctl = Screen.ActiveControl
Select Case ctl.Name
Case "Logon"
SelStart = ctl.SelStart
' Clear deleted digits by resetting the input mask.
ctl.InputMask = DefaultInputMask
ctl.SelStart = SelStart
ctl.SelLength = 1
Response = acDataErrContinue
End Select
Set ctl = Nothing
End Sub
Private Sub Form_Load()
Dim InitialDate As Date
' Set initial date.
InitialDate = Date
' Format and length of DefaultFormat and
' first part of DefaultInputMask must match.
DefaultFormat = "yyyy/mm/dd"
DefaultInputMask = "0000/00/00;1;0"
Me!Logon.Format = DefaultFormat
Me!Logon.InputMask = DefaultInputMask
Me!Logon.ShowDatePicker = False
SetDefaultDate InitialDate
End Sub
Private Sub Logon_AfterUpdate()
With Me!Logon
If IsNull(.Value) Then
' Rem this line out to allow the textbox to be cleared.
.Value = DefaultDate
ElseIf .Value < DateSerial(9999, 12, 31) Then
SetDefaultDate DateAdd("d", 1, .Value)
Else
SetDefaultDate .Value
End If
End With
End Sub
Private Sub Logon_Click()
Dim SelStart As Integer
With Me!Logon
If .SelStart = 4 Or .SelStart = 7 Then
' Move the cursor off the separator (slash)
' to the first digit of months or days.
.SelStart = .SelStart + 1
End If
SelStart = .SelStart
.SelStart = SelStart
.SelLength = 1
End With
End Sub
Private Sub Logon_Enter()
With Me!Logon
If IsNull(.Value) Then
.Value = DefaultDate
End If
End With
End Sub
Private Sub Logon_KeyPress(KeyAscii As Integer)
Dim Text As String
Dim Length As Integer
Dim SelStart As Integer
With Me!Logon
Select Case KeyAscii
Case vbKeyBack, vbKeyTab, Asc(vbLf), vbKeyReturn, vbKeyEscape, vbKeyF16
' Allow navigation etc. with
' BackSpace, Tab, Ctrl+Enter, Enter, Escape, Ctrl+BackSpace
Case Is > 0
Text = .Text
Length = Len(Text)
SelStart = .SelStart
If KeyAscii < vbKey0 Or KeyAscii > vbKey9 Then
' Replace any invalid entry with a zero.
KeyAscii = vbKey0
End If
If SelStart < Length Then
Select Case SelStart
' Year part.
Case Is = 0
' First digit of year.
If KeyAscii = vbKey0 Then
' No year before 1000.
KeyAscii = vbKey1
End If
' Month part.
Case Is = 5
' First digit of month.
If KeyAscii > vbKey1 Then
' No month with tens beyond 1.
KeyAscii = vbKey1
End If
Case Is = 6
' Second digit of month.
Select Case Val(Mid(.Text, 6, 1))
Case Is = 0
' Month is < 10.
If KeyAscii = vbKey0 Then
' Month cannot be 00.
KeyAscii = vbKey1
End If
Case Is > 0
' Month is 10+.
If KeyAscii > vbKey2 Then
' No month beyond 12.
KeyAscii = vbKey2
End If
End Select
' Day part.
Case Is = 8
' First digit of day.
Select Case Val(Mid(.Text, 6, 2))
Case Is = 2
' Month is February.
If KeyAscii > vbKey2 Then
' No day with tens beyond 2 for February.
KeyAscii = vbKey2
End If
Case Else
If KeyAscii > vbKey3 Then
' No day with tens beyond 3.
KeyAscii = vbKey3
End If
End Select
Case Is = 9
' Second digit of day.
Select Case Mid(.Text, 9, 1)
Case Is = 3
' Days of 30.
Select Case Val(Mid(.Text, 6, 2))
Case 1, 3, 5, 7, 8, 10, 12
If KeyAscii > vbKey1 Then
' No day beyond 31.
KeyAscii = vbKey1
End If
Case 4, 6, 9, 11
If KeyAscii > vbKey0 Then
' No day beyond 30.
KeyAscii = vbKey0
End If
End Select
Case Is = 2
' Days of 20.
Select Case Val(Mid(.Text, 6, 2))
Case 2
If KeyAscii = vbKey9 Then
' Check for leap year.
If Month(DateAdd("d", 1, DateSerial(Val(Mid(.Text, 1, 4)), 2, 28))) = 3 Then
' Not a leap year.
KeyAscii = vbKey8
End If
End If
End Select
Case Is = 0
' Days of 00.
If KeyAscii = vbKey0 Then
' No day of 00.
KeyAscii = vbKey1
End If
End Select
End Select
End If
End Select
End With
End Sub
Private Sub SetDefaultDate(ThisDate As Date)
DefaultDate = ThisDate
Me!Logon.DefaultValue = Format(ThisDate, "\#yyyy\/mm\/dd\#")
End Sub
and:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Form_Logon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
Dim DefaultTime As Date
Private Sub Form_Error(DataErr As Integer, Response As Integer)
Const TimeHourMaximum As Integer = 24
Const TimeHourDefault As Integer = 20
Const TimeMinuteTenMax As Integer = 5
Dim ctl As Control
Dim Text As String
Dim SelStart As Integer
On Error Resume Next
Set ctl = Screen.ActiveControl
Select Case ctl.Name
Case "Logon"
Text = ctl.Text
SelStart = ctl.SelStart
If Not IsDate(Text) Then
DoCmd.Beep
If Val(Left(Text, 2)) > TimeHourMaximum Then
Mid(Text, 1) = CStr(TimeHourDefault)
ElseIf Len(Text) > 3 Then
' Length of Text is larger than two hour digits and the kolon.
Mid(Text, 1 + 3) = CStr(TimeMinuteTenMax)
End If
End If
ctl.Text = Text
ctl.SelStart = SelStart
ctl.SelLength = 1
Response = acDataErrContinue
End Select
Set ctl = Nothing
End Sub
Private Sub Form_Load()
Const InitialTime As Date = #6:00:00 AM#
Me!Logon.ShowDatePicker = False
Me!Logon.InputMask = "90:00;1;0"
Me!Logon.Format = "hh:nn"
SetDefaultTime InitialTime
End Sub
Private Sub Logon_AfterUpdate()
With Me!Logon
If IsNull(.Value) Then
' Rem this line out to allow the textbox to be cleared.
.Value = #12:00:00 AM#
Else
SetDefaultTime DateAdd("n", 1, .Value)
End If
End With
End Sub
Private Sub Logon_Click()
With Me!Logon
If .SelStart = 2 Then
' Move the cursor off the separator (colon)
' to the first digit of minutes.
.SelStart = 3
.SelLength = 1
End If
End With
End Sub
Private Sub Logon_Enter()
With Me!Logon
If IsNull(.Value) Then
.Value = DefaultTime
End If
End With
End Sub
Private Sub Logon_KeyPress(KeyAscii As Integer)
Dim Text As String
Dim Char As String
Dim Length As Integer
Dim SelStart As Integer
With Me!Logon
Select Case KeyAscii
Case vbKeyBack, vbKeyTab, Asc(vbLf), vbKeyReturn, vbKeyEscape, vbKeyF16
' Allow navigation etc. with
' BackSpace, Tab, Ctrl+Enter, Enter, Escape, Ctrl+BackSpace
Case Is > 0
Text = .Text
Length = Len(Text)
SelStart = .SelStart
If KeyAscii < vbKey0 Or KeyAscii > vbKey9 Then
' Replace any invalid entry with a zero.
KeyAscii = vbKey0
End If
Char = Mid(Text, 1 + SelStart, 1)
If SelStart < Length Then
If KeyAscii <= vbKey0 + 2 Then
' Always accept 0, 1, 2.
Else
' Check if the text will represent a valid time.
' If not, restore the overwritten digit.
Mid(Text, 1 + SelStart, 1) = Chr(KeyAscii)
If Not IsDate(Text) Then
DoCmd.Beep
KeyAscii = Asc(Char)
End If
End If
End If
End Select
End With
End Sub
Private Sub SetDefaultTime(ThisTime As Date)
DefaultTime = ThisTime
Me!Logon.DefaultValue = Format(ThisTime, "\#hh:nn:00 AM/PM\#")
End Sub
In response to Thomas G and RRO, put this code into the Code Builder for one of the Date fields, After Update Function.
Dim X As String
X = Format (Now(), "hh:mm:ss")
Me!YourFieldName.Value = X
Related
I've got 5 comboboxes in my form, and I would like the user to only be able to select 2. Once 2 is selected, the other 3 will be disabled? How'd I go about this? I know you can do one combobox and disable the rest by afterupdate as below. Appreciate your help! :)
Private Sub cboOR_AfterUpdate()
Me.cboA.Enabled = False
End Sub
Check this out
Private Sub Combo0_AfterUpdate()
If CheckCombo Then
disableCombo
Else
enableCombo
End If
End Sub
Private Sub Combo10_AfterUpdate()
If CheckCombo Then
disableCombo
Else
enableCombo
End If
End Sub
Private Sub Combo12_AfterUpdate()
If CheckCombo Then
disableCombo
Else
enableCombo
End If
End Sub
Private Sub Combo14_AfterUpdate()
If CheckCombo Then
disableCombo
Else
enableCombo
End If
End Sub
Private Sub Combo16_AfterUpdate()
If CheckCombo Then
disableCombo
Else
enableCombo
End If
End Sub
Private Function CheckCombo() As Boolean
Dim retVal As Long
retVal = IIf(Len(Nz(Combo0, "")) > 0, 1, 0) + IIf(Len(Nz(Combo10, "")) > 0, 1, 0) + IIf(Len(Nz(Combo12, "")) > 0, 1, 0) + IIf(Len(Nz(Combo14, "")) > 0, 1, 0) + IIf(Len(Nz(Combo16, "")) > 0, 1, 0)
CheckCombo = (retVal >= 2)
End Function
Private Sub enableCombo()
Combo0.Enabled = True
Combo10.Enabled = True
Combo12.Enabled = True
Combo14.Enabled = True
Combo16.Enabled = True
End Sub
Private Sub disableCombo()
If Len(Nz(Combo0, "")) <= 0 Then Combo0.Enabled = False
If Len(Nz(Combo10, "")) <= 0 Then Combo10.Enabled = False
If Len(Nz(Combo12, "")) <= 0 Then Combo12.Enabled = False
If Len(Nz(Combo14, "")) <= 0 Then Combo14.Enabled = False
If Len(Nz(Combo16, "")) <= 0 Then Combo16.Enabled = False
End Sub
Put this Sub in form's module
Private Sub changeStateOfCB()
Dim nameChB() As String
Dim cMax As Long
Dim ctrl As Control
Dim cValued As Long
Dim nameCurr As Variant
' names of CB
nameChB = Split("ComboName1#ComboName2#ComboName3#ComboName4#ComboName5", "#")
' max allowed values
cMax = 2
' counting with values
For Each nameCurr In nameChB
If Not Me.Controls(nameCurr).Value Is Null Then
cValued = cValued + 1
End If
Next
' disabling if needed
For Each nameCurr In nameChB
If Not Me.Controls(nameCurr).Value Is Null Then
Me.Controls(nameCurr).Enabled = (cValued < cMax)
End If
Next
End Sub
Change names in string according to you names in nameChB line.
And for every combo box create AfterUpdate event procedures with call
changeStateOfCB
I would like to sort data in MS Access, and for that I am using a query. The data in my table is like:
RadButtonNo
-------------------
AA001056
AA001579
B000049
AA001261
AA001158
AA001108
AA001166
AA001165
AA001164
AA001163
AA001162
For my output, the data I would like first would be only data which consists of letters. Following that, I would like to display letters and numbers. So, it would look something like this:
AAAAAAA
AABBBBB
AAZZZZZ
ABA1001
I am using the following query:
SELECT RadButtonNo, ShortName, InspectionDate, Findings, Status, QueryForNot1.Initials, DeptName, Lost, TableApron.InServelDate, TableApron.RemovedDate,
TableApron.PrivateUserName, TableApron.PrivateUserEmail, TableApron.ApronType, TableApron.Manufacturer
FROM TableApron
LEFT JOIN QueryForNot1 ON TableApron.RadButtonNo=QueryForNot1.RadButtonNoI
WHERE (((TableApron.Lost)="N" Or (TableApron.Lost)=[#Lost])
ORDER BY LEN(TableApron.RadButtonNo) DESC , TableApron.RadButtonNo;
Can someone fix this so that it will produce my desired output?
You can use these two functions:
Public Function TrimNumString( _
ByVal strNumString As String, _
Optional ByVal strDecimalChr As String, _
Optional ByVal booAcceptMinus As Boolean) _
As String
' Removes any non-numeric character from strNumString including hexadecimal characters.
' If strDecimalChr is specified, first occurrence of this is not removed.
' If booAcceptMinus is True, a leading or trailing minus sign is accepted.
'
' 1999-08-27. Cactus Data ApS, CPH.
' 2001-06-21. Speed optimized for large string (64 K).
' 2003-12-10. intOffset changed to lngOffset.
Const cbytNeg As Byte = 45 ' "-"
Dim lngPos As Long
Dim lngLen As Long
Dim lngOffset As Long
Dim booDec As Boolean
Dim booNeg As Boolean
Dim bytChr As Byte
Dim bytDec As Byte
Dim strNum As String
strNumString = Trim(strNumString)
lngLen = Len(strNumString)
If lngLen > 0 Then
If Len(strDecimalChr) > 0 Then
bytDec = Asc(strDecimalChr)
End If
' Create empty result string of maximum possible length.
strNum = Space(lngLen)
For lngPos = 1 To lngLen
bytChr = Asc(Mid(strNumString, lngPos, 1))
Select Case bytChr
Case 48 To 57
' Digit.
Case bytDec
' Decimal point.
If booDec = False Then
' One decimal point only.
booDec = True
End If
Case cbytNeg
' Minus sign.
bytChr = 0
If booAcceptMinus = True And booNeg = False Then
If Len(Trim(strNum)) = 0 Or lngPos = lngLen Then
bytChr = cbytNeg
' One minus sign only.
booNeg = True
End If
End If
Case Else
' Ignore any other character.
bytChr = 0
End Select
If bytChr > 0 Then
' Append accepted character by inserting it in result string.
lngOffset = lngOffset + 1
Mid(strNum, lngOffset) = Chr(bytChr)
End If
Next
End If
' Trim and return result string.
TrimNumString = Left(strNum, lngOffset)
End Function
Public Function TrimTxtString( _
ByVal strTxtString As String) _
As String
' Removes any numeric character from strTxtString.
'
' 2003-12-19. Cactus Data ApS, CPH.
Dim lngPos As Long
Dim lngLen As Long
Dim lngOffset As Long
Dim bytChr As Byte
Dim strNum As String
strTxtString = Trim(strTxtString)
lngLen = Len(strTxtString)
If lngLen > 0 Then
' Create empty result string of maximum possible length.
strNum = Space(lngLen)
For lngPos = 1 To lngLen
bytChr = Asc(Mid(strTxtString, lngPos, 1))
Select Case bytChr
Case 48 To 57
' Digit.
bytChr = 0
Case Else
' Accept any other character.
End Select
If bytChr > 0 Then
' Append accepted character by inserting it in result string.
lngOffset = lngOffset + 1
Mid(strNum, lngOffset) = Chr(bytChr)
End If
Next
End If
' Trim and return result string.
TrimTxtString = Left(strNum, lngOffset)
End Function
Then adjust your SQL:
ORDER BY LEN(TableApron.RadButtonNo) DESC, TrimTxtString([TableApron].[RadButtonNo]), TrimNumString([TableApron].[RadButtonNo]);
Group entries by appending a character/or more to the entries with digits. Sort o that new field. I use here a value with all z and extra z to exclude a real entry of z's.
SELECT RadButtonNo
from tbl
order by IIF(RadButtonNo like "*#*", "zzzzzzzzz" & RadButtonNo, RadButtonNo)
I've created a public function in Access. My goal is if the next business day is a holiday I'm calculating one extra day of interest for payoff purposes. Below is the working code I have. The issue I'm haveing is I'm dealing with over 35000 records and the time it takes to run the query is too long. If there is a better way of do this I will definitely give it a try. Thanks!
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
If Not (rst.EOF And rst.BOF) Then
Do While Not rst.EOF
If rst("HolidayDate") = NextBusDay Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
rst.MoveNext
Loop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End Function
Here is one solution to avoid the opening the Holiday table 35,000 times. It will load all dates into an Array (only once), then use that array for comparing. But I am curious if your existing process ever worked correctly 100% of the time -- if that table contained more than one holiday? Specifically, when you read the holiday table (regardless of the sort order), then in your loop "If rst("HolidayDate") = NextBusDay Then", since you don't exit the loop if you get a match, your subroutine should always return the results of what happens when checking the last date in the table? Also I didn't find a Dim for NextBusDay, so I added it.
Option Compare Database
Option Explicit
Public blnSetArray As Boolean
Public dHolidays() As Date
Public iHolidays As Integer
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As Database
Dim rst As Recordset
Dim i As Integer
Dim iLoop As Integer
Dim NextBusDay As Date
' Save an array of dates the first time
If blnSetArray = False Then
Set db = CurrentDb
Set rst = db.OpenRecordset("tbl_Holidays", dbOpenDynaset)
i = 0
If Not (rst.EOF And rst.BOF) Then
rst.MoveLast
rst.MoveFirst
iHolidays = rst.RecordCount
ReDim dHolidays(rst.RecordCount)
Do While Not rst.EOF
i = i + 1
dHolidays(i) = rst("HolidayDate")
rst.MoveNext
Loop
End If
blnSetArray = True
rst.Close 'Close the recordset
Set rst = Nothing 'Clean up
db.Close
Set db = Nothing
End If
Select Case DatePart("w", Date)
Case 6
NextBusDay = Date + 3
Case 7
NextBusDay = Date + 2
Case Else
NextBusDay = Date + 1
End Select
HolidayInterest = 0 ' Set as default
If iHolidays > 0 Then
For iLoop = 1 To iHolidays
If dHolidays(iLoop) = NextBusDay Then
HolidayInterest = Perdiem
Exit For ' No need to stay in loop
End If
Next iLoop
Else
'MsgBox "There are no records in the recordset."
End If
'MsgBox "Finished looping through records."
End Function
Function MyTest()
blnSetArray = False
Debug.Print HolidayInterest(100#)
End Function
Apart from the Perdiem value you pass as an argument to your function, the only thing that will affect the return value of your function is the current system date as returned by Date. In other words, on any given day your function will always return either the Perdiem value or zero.
Therefore, we can use a Static variable named TheDateToday to hold the current date and you will only have to hit the [tbl_Holidays] table once on any given day:
Option Compare Database
Option Explicit
Public Function HolidayInterest(Perdiem As Currency) As Currency
Dim db As DAO.Database, qdf As DAO.QueryDef, rst As DAO.Recordset
Dim NextBusDay As Date
Static TheDateToday As Date, NextBusDayIsHoliday As Boolean
If CLng(TheDateToday) <> CLng(Date) Then
TheDateToday = Date
Select Case DatePart("w", TheDateToday)
Case 6
NextBusDay = DateAdd("d", 3, TheDateToday)
Case 7
NextBusDay = DateAdd("d", 2, TheDateToday)
Case Else
NextBusDay = DateAdd("d", 1, TheDateToday)
End Select
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", _
"PARAMETERS prmDate DateTime;" & _
"SELECT * FROM tbl_Holidays WHERE HolidayDate=[prmDate]")
qdf!prmDate = NextBusDay
Set rst = qdf.OpenRecordset(dbOpenSnapshot)
NextBusDayIsHoliday = Not (rst.EOF And rst.BOF)
rst.Close
Set rst = Nothing
Set qdf = Nothing
Set db = Nothing
End If
If NextBusDayIsHoliday Then
HolidayInterest = Perdiem
Else
HolidayInterest = 0
End If
End Function
I'm writing code in access vba for the list box items to move up and down. Needs to use .List Property in access . But it throws an error says no method or member found. Any replace method with .List ? Researching on this more than 4 days.
Private Sub cmdUP_Click()
Dim i As Long
Dim leaveAlone As Boolean
Dim pos As Long
Dim Temp As String
pos = 0
With Me.lbfNames
For i = 0 To .ListCount - 1
leaveAlone = False
If .Selected(i) Then
If i = pos Then
leaveAlone = True
End If
pos = pos + 1
If leaveAlone = False Then
Temp = .RowSource(i - 1)
.RowSource(i - 1) = .RowSource(i) ' before i used .List instead of rowsource
.RowSource(i) = Temp
.ListIndex = i - 1
.Selected(i) = False
.Selected(i - 1) = True
End If
End If
Next
End With
I've figured that out, how to do it in access. But set list box Multiselect property to 'None'.
Moving Down
Private Sub cmdDown_Click()
Dim sText As String
Dim iIndex As Integer
Dim bottomLimit As Integer
iIndex = lbfNames.ListIndex
bottomLimit = lbfNames.ListCount - 1
'check: only proceed if there is a selected item
If lbfNames.ListCount > 1 Then
If iIndex >= bottomLimit Then
MsgBox ("Can not move the item down any further.")
Exit Sub
End If
'save items text and items indexvalue
sText = lbfNames.Column(0, iIndex)
If iIndex < bottomLimit Then
lbfNames.RemoveItem iIndex
'place item back in new position
lbfNames.AddItem sText, iIndex + 1
End If
'if you keep that item selected
'you can keep moving it by pressing btnMoveDown
lbfNames.Selected(iIndex + 1) = True
iIndex = iIndex + 1
End If
End Sub
Moving up
Private Sub cmdUP_Click()
Dim sText As String
Dim iIndex As Integer
iIndex = lbfNames.ListIndex
' ReDim iIndex(0 To 10)
'check: only proceed if there is a selected item
If lbfNames.ListCount > 1 Then
'index 0 is top item which can't be moved up!
If iIndex <= 0 Then
MsgBox ("Can not move the item up any higher.")
Exit Sub
End If
' If iIndex = -1 Or lbfNames.ListCount > 1 Then
'save items text and items indexvalue
sText = lbfNames.Column(0, iIndex)
lbfNames.RemoveItem iIndex
'place item back on new position
lbfNames.AddItem sText, iIndex - 1
'if you keep that item selected
'you can keep moving it by pressing cmdUp
lbfNames.Selected(iIndex - 1) = True
iIndex = iIndex - 1
End If
End Sub
Short Answer: No, MS Access VBA doesn't have ListBox.List(row, column) but instead it has ListBox.AddItem(Item, Index) and ListBox.RemoveItem(Index)
For Multi-Column ListBoxes semi-colon character ';' could be used to separate column items i.e. myMultiColListBox.AddItem("Col_1_item;Col_2_item;Col_3_item")
Basically I'm trying to use a Module or Public functions to pull a datediff that is only for business days. Everything works as far as the code is concerned but for some reason with a particular date field (one I've added after the database has been in production for some time) the code is not working correctly and I'm getting the "Data Type Mismatch in Expression". I'm 99% sure this is a data problem. If I compare two different dates it runs, I've created a test table with 10 records and it runs.
The field is set to Date/Time. I guess my question is, is there anyway to get rid of the ""'s or make it so the code will accept these blanks as nulls? or convert them?
This is where I call the function in the query:
Exp1: BusinessDays([IntCallDate],[aIntCall1])
And here is the code in the module...
Thanks for any help - MUCH appreciated!!!
Public Function BusinessDays(dteStartDate As Date, dteEndDate As Date) As Long
On Error GoTo err_workingDays
Dim lngYear As Long
Dim lngEYear As Long
Dim dteStart As Date, dteEnd As Date
Dim dteCurr As Date
Dim lngDay As Long
Dim lngDiff As Long
Dim lngACount As Long
Dim dteLoop As Variant
Dim blnHol As Boolean
Dim dteHoliday() As Date
Dim lngCount As Long, lngTotal As Long
Dim lngThanks As Long
If IsDate(dteStartDate) And IsDate(dteEndDate) Then 'added here begin
dteStart = dteStartDate
dteEnd = dteEndDate
lngYear = DatePart("yyyy", dteStart)
lngEYear = DatePart("yyyy", dteEnd)
If lngYear <> lngEYear Then
lngDiff = (((lngEYear - lngYear) + 1) * 7) - 1
ReDim dteHoliday(lngDiff)
Else
ReDim dteHoliday(6)
End If
lngACount = -1
For lngCount = lngYear To lngEYear
lngACount = lngACount + 1
'July Fourth
dteHoliday(lngACount) = DateSerial(lngCount, 7, 4)
lngACount = lngACount + 1
'Christmas
dteHoliday(lngACount) = DateSerial(lngCount, 12, 25)
lngACount = lngACount + 1
'New Years
dteHoliday(lngACount) = DateSerial(lngCount, 1, 1)
lngACount = lngACount + 1
'Thanksgiving - 4th Thursday of November
lngDay = 1
lngThanks = 0
Do
If Weekday(DateSerial(lngCount, 11, lngDay)) = 5 Then
lngThanks = lngThanks + 1
End If
lngDay = lngDay + 1
Loop Until lngThanks = 4
dteHoliday(lngACount) = DateSerial(lngCount, 11, lngDay)
lngACount = lngACount + 1
'Memorial Day - Last Monday of May
lngDay = 31
Do
If Weekday(DateSerial(lngCount, 5, lngDay)) = 2 Then
dteHoliday(lngACount) = DateSerial(lngCount, 5, lngDay)
Else
lngDay = lngDay - 1
End If
Loop Until dteHoliday(lngACount) >= DateSerial(lngCount, 5, 1)
lngACount = lngACount + 1
'Labor Day - First Monday of Septemeber
lngDay = 1
Do
If Weekday(DateSerial(lngCount, 9, lngDay)) = 2 Then
dteHoliday(lngACount) = DateSerial(lngCount, 9, lngDay)
Else
lngDay = lngDay + 1
End If
Loop Until dteHoliday(lngACount) >= DateSerial(lngCount, 9, 1)
'MsgBox dteHoliday(5)
lngACount = lngACount + 1
'Easter
lngDay = (((255 - 11 * (lngCount Mod 19)) - 21) Mod 30) + 21
dteHoliday(lngACount) = DateSerial(lngCount, 3, 1) + lngDay + _
(lngDay > 48) + 6 - ((lngCount + lngCount \ 4 + _
lngDay + (lngDay > 48) + 1) Mod 7)
Next
For lngCount = 1 To DateDiff("d", dteStart, dteEnd)
dteCurr = (dteStart + lngCount)
If (Weekday(dteCurr) <> 1) And (Weekday(dteCurr) <> 7) Then
blnHol = False
For dteLoop = 0 To UBound(dteHoliday)
'MsgBox dteHoliday(dteLoop) & " " & dteLoop
If (dteHoliday(dteLoop) = dteCurr) Then
blnHol = True
End If
Next dteLoop
If blnHol = False Then
lngTotal = lngTotal + 1
'MsgBox dteCurr
End If
End If
Next lngCount
BusinessDays = lngTotal
Else 'Add
BusinessDays = -1 ' add
End If 'add
err_workingDays:
MsgBox "Error No: " & Err.Number & vbCr & _
"Description: " & Err.Description
Resume exit_workingDays
End Function
The code fails when Year(dteStartDate) > Year(dteEndDate)
You can't ReDim an array to a negative value.
When lngEYear < lngYear, lngDiff will be less than zero.
I'm not sure that this line:
If IsDate(dteStartDate) And IsDate(dteEndDate) Then 'added here begin
is necessary, since you'll get Type Mismatch errors if you try to feed other types of values into the function. In any case, you also/instead should have something like:
If dteStartDate <= dteEndDate Then
with the Else portion returning a "known bad" answer, the way your code does here:
Else 'Add
BusinessDays = -1 ' add
End If 'add
This is just an expansion of the answers already posted by Jim Anderson
and mwolfe02
. If you accept this answer/vote it up, you should also vote up theirs....
You're getting a data type mismatch because you have declared the parameters as Date type. While a Date/Time column in the database can hold a null value, a Date variable in VBA cannot. You must therefore declare the parameters as Variants, and do some type checking at the head of your function.
This means that my comment to another answer (saying that IsDate will always return true here) is misleading. Rather than deleting the meaningless IsDate check, you should make the check meaningful by changing the parameter type from Date to Variant.
Hope this helps.