Sub Main()
StartTime = Now()
TDate = CDate(Format(Now(), "MM/DD/YYYY"))
My = Environ("Username")
Set db = CurrentDb
Set rs = db.OpenRecordset("Emp", dbOpenDynaset)
Criteria = "ID = '" & My & "' And From_Date >= '" & TDate & "' And To_Date <= '" & StartTime & "' "
rs.FindFirst Criteria
If rs.NoMatch Then
MsgBox "Record not found"
else
MsgBox "Record found"
end if
Please help to run this code as I would like to find first record between start date & end date.
For a date you should use a "#" as enclosing character:
Criteria = "ID = '" & My & "' And From_Date >= #" & TDate & "# And To_Date <= #" & StartTime & "# "
You are mixing up date and time formatting:
Sub Main()
' Dim StartTime As Date
' Dim TDate As Date
StartTime = Now
TDate = DateValue(StartTime)
My = Environ("Username")
Set db = CurrentDb
Set rs = db.OpenRecordset("Emp", dbOpenDynaset)
Criteria = "ID = '" & My & "' And From_Date >= #" & Format(TDate, "yyyy\/mm\/dd") & "# And To_Date <= #" & Format(StartTime, "yyyy\/mm\/dd") & "#'"
rs.FindFirst Criteria
If rs.NoMatch Then
MsgBox "Record not found"
Else
MsgBox "Record found"
End If
End Sub
However, it could be reduced to:
Sub Main()
My = Environ("Username")
Set db = CurrentDb
Set rs = db.OpenRecordset("Emp", dbOpenDynaset)
Criteria = "ID = '" & My & "' And From_Date >= Date() And To_Date <= Now()"
rs.FindFirst Criteria
If rs.NoMatch Then
MsgBox "Record not found"
Else
MsgBox "Record found"
End If
End Sub
Related
This is a practicum attendance management system. I'm only using one button to make the attendance work.
Dim query2 As String = "UPDATE attendance att, practicum prac SET att.LastName = prac.LastName, att.FirstName = prac.FirstName WHERE att.PracticumID = prac.PracticumID"
Try
If TextBox1.Text = "" Then
MessageBox.Show("retry")
Else
reloadtxt("SELECT * FROM practicum WHERE PracticumID = '" & TextBox1.Text & "'")
If dt.Rows.Count > 0 Then
reloadtxt("SELECT * FROM attendance WHERE PracticumID = '" & TextBox1.Text & "' AND DATE = '" & logdate _
& "' AND AM_Status = 'OUT'")
If dt.Rows.Count > 0 Then
MessageBox.Show("you've had enough for this day", "attention", MessageBoxButtons.OK, MessageBoxIcon.Information)
Else
reloadtxt("SELECT * FROM attendance WHERE PracticumID = '" & TextBox1.Text & "' AND AM_Status = 'IN'")
If dt.Rows.Count > 0 Then
Dim amout As String = "UPDATE attendance SET TimeLogOut_AM = '" & timeout_am & "', AM_Status = 'Out' WHERE PracticumID = '" & TextBox1.Text & "'"
Dim QueryString2 As String = String.Concat(amout, ";", query2)
updates(QueryString2)
load_PracticumAttendance()
MessageBox.Show("AM TimeOut")
Else
Dim amin As String = "INSERT INTO attendance (PracticumID, Date, TimeLogIn_AM, AM_Status) " _
& " VALUES ('" & TextBox1.Text & "', '" & logdate & "', '" & timein_am & "', 'IN')"
Dim QueryString As String = String.Concat(amin, ";", query2)
create(QueryString)
load_PracticumAttendance()
MessageBox.Show("AM TimeIn")
End If
End If
Else
End If
End If
this is my sample output
Now, how will I make it to have an output on TimeIn - PM and TimeOut - PM? I mean, for example, a practicum will time in by 8am then time out at 12nn. Then they will have a lunch break in which after that, they will time in again by 1pm then out by 5pm. I'm using the PracticumID to input it to the textbox. How do I make it possible to make an attendance afterlunch? because I can only do time in and time out in the morning.
I'm not a VBA expert. I simply copy from the net and try to utilize in my program. however, below is my codes. I'm trying to calculate a finish date considering offdays, but the issue is sometime the time required is less than one day in that case it is calculating as 1 day. How can I calculate it by hours. Suppose if the startdate is 1-jan-2019 6:00 am and the required time to produce is 6 hours than the finish time should be 1-jan-2019 12:00pm
Public Function AddFinishDate(StartDate As Date, ReqDays As Double, FriOff As Boolean) As Date
Dim rst As Recordset
Dim db As Database
Dim FinishDate As Date
Dim icount As Integer
On Error GoTo errhandlers:
Set db = CurrentDb
Set rst = db.OpenRecordset("tblHoliday", dbOpenSnapshot)
icount = 0
FinishDate = StartDate
Do While icount < ReqDays
FinishDate = FinishDate + 1
If Weekday(FinishDate, vbSaturday) <> 7 Or FriOff = False Then
rst.FindFirst "(HolidayDate)= #" & FinishDate & "#"
If rst.NoMatch Then
icount = icount + 1
End If
End If
Loop
AddFinishDate = FinishDate
exit_errhandlers:
rst.Close
Set rst = Nothing
Set db = Nothing
AddFinishDate = FinishDate
Exit Function
errhandlers:
MsgBox Err.Description, vbExclamation
Resume Next
End Function
Private Sub Command53_Click()
Dim dbs As DAO.Database
Set dbs = CurrentDb()
dbs.Execute "UPDATE BalFitToFabricate " & "SET used = false , startdate ="""",finishdate ="""";"
Me.Refresh
End Sub
Private Sub Command71_Click()
Dim dbs As DAO.Database, Initrst, rst, rst2 As DAO.Recordset
Dim strSQL
Dim ClientsTableQuery, SalesRepList As TableDef
Dim DataB As Database
Dim ClientQD As QueryDef
Dim rstClient As DAO.Recordset
Dim DurationTotal, Counter, i As Integer
Dim LowDate1, LowDate2 As Date
Dim tmpArray(10), FieldArray(10), TempDate1, TempDate2 As Date
Dim TotalDailyHrs, TempDailyHours As Integer
Dim FirstTimeIn As Boolean
FirstTimeIn = False
TotalDailyHrs = Forms("BalFitToFabricate").Text49.Value
TempDailyHours = TotalDailyHrs
Set dbs = CurrentDb()
ClientsTableQuery = "BalFitToFabricate"
'strSQL = "Select * from Client_Table"
Set DataB = CurrentDb()
Set rstClient = DataB.OpenRecordset(ClientsTableQuery)
rstClient.MoveFirst
Counter = 0
Set Initrst = dbs.OpenRecordset("SELECT * FROM BalFitToFabricate;")
'Set rst = dbs.OpenRecordset("SELECT * FROM BalFitToFabricate;")
Set rst = dbs.OpenRecordset("SELECT * FROM (SELECT * FROM (SELECT * FROM BalFitToFabricate WHERE Used = false)) WHERE FinishDate = (select min(FinishDate) from BalFitToFabricate where Used = false);")
Set rst2 = dbs.OpenRecordset("SELECT * FROM BalFitToFabricate WHERE isnull(StartDate) order by NULLSORTER,Req_Del_Date,Priority;")
'Autonumrst.Requery
'MsgBox Initrst.RecordCount & " " & rst.RecordCount & " " & rst2.RecordCount
'First Loop
Do Until rstClient.EOF = True
If TempDailyHours <= TotalDailyHrs Then
'Autonumrst.Requery
'If FirstTimeIn = False Then
' TotalDailyHrs = TotalDailyHrs - TempDailyHours
'End If
TempDailyHours = Initrst![CreqHours]
Dim Autonumrst, Valuesrst As DAO.Recordset
Dim strSQL2, strSQL3 As String
'strSQL2 = "SELECT [Crew Hours] FROM Table2 where AutoNum = " & Initrst!Autonum & "and used = false;"
strSQL2 = "SELECT [CreqHours] FROM Table2 where Used = False;"
strSQL3 = "SELECT * FROM Table2 where Used = False;"
Set Autonumrst = CurrentDb.OpenRecordset(strSQL2)
Set Valuesrst = CurrentDb.OpenRecordset(strSQL3)
' new code:
'Stopped 2 lines
'TempDailyHours = Autonumrst![Crew Hours]
'Autonumrst.Requery
'Autonumrst.Close
'TempDailyHours = dbs.Execute "select BalFitToFabricate " & "SET startdate = #" & TempDate1 & "# WHERE Autonum = " & Initrst!Autonum & ";"
TotalDailyHrs = TotalDailyHrs - TempDailyHours
If TotalDailyHrs > 0 Then
TempDate1 = Format([Forms]![BalFitToFabricate]![Text51].Value, "mm-dd-yyyy")
'TempDate1 = [Forms]![BalFitToFabricate]![Text68].Value
dbs.Execute "UPDATE BalFitToFabricate " & "SET startdate = #" & TempDate1 & "# WHERE ID = " & Initrst!ID & ";"
TempDate2 = AddFinishDate(Format(TempDate1, "mm-dd-yyyy"), Initrst!ReqDays, Me.FridayOffCheckBox2)
dbs.Execute "UPDATE BalFitToFabricate " & "SET finishdate = #" & TempDate2 & "# WHERE ID = " & Initrst!ID & ";"
'TempDate1 = strSQL59 + (strSQL22 / strSQL57)
'TempDate2 = Format(TempDate1 + (Valuesrst![Total_Req_Manhours] / Valuesrst![Crew Hours]), "dd-mm-yyyy")
'dbs.Execute "UPDATE BalFitToFabricate " & "SET Finishdate = #" & TempDate2 & "# WHERE Autonum = " & Initrst!AutoNum & ";"
dbs.Execute "UPDATE BalFitToFabricate " & "SET Used = True WHERE ID = " & Initrst!ID & ";"
End If
Initrst.MoveNext
'Autonumrst.MoveNext
Else
GoTo ExitLoop1
End If
Loop
ExitLoop1:
'MsgBox rst!Ord_No & " " & rst2!Ord_No
dbs.Execute "UPDATE BalFitToFabricate " & "SET Used = False;"
TotalDailyHrs = Forms("BalFitToFabricate").Text49.Value
TempDailyHours = TotalDailyHrs
'Second Loop
Do Until rstClient.EOF = True
'Counter = Counter + 1
'i = rstClient!Ord_No
'If rstClient.Fields("Duration") <> "" Then
' DurationTotal = DurationTotal + rstClient.Fields("Duration")
'FieldArray(Counter) = rstClient.Fields("End")
'End If
'If DurationTotal >= 15 Then
If TempDailyHours <= TotalDailyHrs Then
'If rstClient!Used = False Then
strSQL3 = "SELECT * FROM Table2 where Finishdate is null;"
Set Valuesrst = CurrentDb.OpenRecordset(strSQL3)
Valuesrst.Requery
'Counter = rst2.RecordCount
Dim temp22 As Integer
temp22 = rst.RecordCount
rst.Requery
rst2.Requery
If rst2.RecordCount <= 0 Then
GoTo ExitLoop2
End If
LowDate1 = "#" & rst!FinishDate & "#"
'LowDate2 = "#" & Valuesrst!finishdate & "#"
'End If
''Set dbs = OpenDatabase("database41.accdb")
TempDate1 = Format(rst!FinishDate, "mm-dd-yyyy")
dbs.Execute "UPDATE BalFitToFabricate " & "SET Used = true WHERE ID = " & rst!ID & ";"
dbs.Execute "UPDATE BalFitToFabricate " & "SET startdate = #" & TempDate1 & "# WHERE ID = " & rst2!ID & ";"
'TempDate1 = Format([Forms]![BalFitToFabricate]![Text59].Value + ([Forms]![BalFitToFabricate]![Text22].Value / [Forms]![BalFitToFabricate]![Text57].Value), "dd-mm-yyyy")
'TempDate1 = Format(Valuesrst![StartDate] + (Valuesrst![Total_Req_Manhours] / Valuesrst![Crew Hours]), "dd-mm-yyyy")
'dbs.Execute "UPDATE BalFitToFabricate " & "SET Finishdate = #" & TempDate1 & "# WHERE Autonum = " & Valuesrst!AutoNum & ";"
TempDate2 = AddFinishDate(Format(TempDate1, "mm-dd-yyyy"), rst!ReqDays, Me.FridayOffCheckBox2)
dbs.Execute "UPDATE BalFitToFabricate " & "SET finishdate = #" & TempDate2 & "# WHERE ID = " & rst2!ID & ";"
End If
'rstClient.MoveNext
Loop
ExitLoop2:
MsgBox "Finished Scheduling " & DurationTotal & "Time: " & Time()
rstClient.Close
[Forms]![BalFitToFabricate].Refresh
End Sub
This is not that easy, if you don't work round the clock. I have an old function that takes off-hours and weekends in consideration, though not holidays:
Public Function WorkhourAdd( _
ByVal datDateStart As Date, _
ByVal intHours As Integer) _
As Date
' Purpose: Add number of working hours to date datDateStart.
' Assumes: 5 working days per week. Adjust cbytWorkdaysOfWeek for other values.
' First workday is Monday.
' Weekend is up to and including Sunday.
' Limitation: Does not count for public holidays.
' May be freely used and distributed.
'
' 2011-01-15. Gustav Brock, Cactus Data ApS, Copenhagen
' Specify begin and end time of daily working hours.
Const cdatWorkTimeStart As Date = #8:00:00 AM#
Const cdatWorkTimeStop As Date = #4:00:00 PM#
Const cbytWorkdaysOfWeek As Byte = 5
Dim intCount As Integer
Dim datDateEnd As Date
datDateEnd = datDateStart
While intCount < intHours
datDateEnd = DateAdd("h", 1, datDateEnd)
If Weekday(datDateEnd, vbMonday) <= cbytWorkdaysOfWeek Then
If DateDiff("h", cdatWorkTimeStart, TimeValue(datDateEnd)) > 0 Then
If DateDiff("h", TimeValue(datDateEnd), cdatWorkTimeStop) >= 0 Then
intCount = intCount + 1
End If
End If
End If
Wend
WorkhourAdd = datDateEnd
End Function
You could modify it to check if time is within a holiday, to find finish time across holidays.
I want to count the call number, Datecall, [Username] is the name of fields of table BCKHDY but why numbercall always equal 0. If I delete AND DateCall= #" & DateFrom & "#, code run, that mean there is something wrong with Datecall. What 's wrong?
Private Sub txtnbCall_Click()
Dim mydept As Integer
DateFrom = Me.txtfrom.Value
User = Forms![Navigation form]![txtLogin].Value
If Not IsNull(DLookup("Deptname", "tblUser", "UserLogin = '" & User & "'")) Then
mydept = DLookup("Deptname", "tblUser", "UserLogin = '" & User & "'")
Me.txtnbCall = numbercall(mydept, DateFrom)
End If
End Sub
Public Function numbercall(ByVal mydept As Integer, _
ByVal DateFrom As Date) As Integer
numbercall = DCount("CompanyName", "BCKHDY", _
"[UserName] = " & mydept & "AND DateCall >= #" & DateFrom & "#")
End Function
You're missing a space here:
mydept & "AND
Should be
mydept & " AND
Only spaces inside a string count. If you forget the space, the criteria would include something like 1And
You also need to format the date as either yyyy-MM-dd or MM/dd/yyyy:
"[UserName] = " & mydept & " AND DateCall >= #" & Format(DateFrom, "yyyy-MM-dd") & "#")
You don't have to call DLookup twice, do declare all variables, and you probably filter on the wrong field in DCount:
Private Sub txtnbCall_Click()
Dim mydept As Variant
Dim DateFrom As Date
Dim User As String
DateFrom = Me!txtfrom.Value
User = Forms![Navigation form]![txtLogin].Value
mydept = DLookup("Deptname", "tblUser", "UserLogin = '" & User & "'")
If Not IsNull(mydept) Then
Me!txtnbCall.Value = numbercall(mydept, DateFrom)
End If
End Sub
Public Function numbercall(ByVal mydept As Integer, _
ByVal DateFrom As Date) As Integer
numbercall = DCount("*", "BCKHDY", _
"[Deptname] = " & mydept & " AND DateCall >= #" & Format(DateFrom, "yyyy\/mm\/dd") & "#")
End Function
I am pulling data from database into a recordset then converting to array and then writing to a CSV.
In the database all date values are stored as timestamps in this format.
2016-05-04 08:00:00.000000
But when I write to the CSV file the timestamp does not include the milliseconds.
Anyone know how to preserve the milliseconds?
Does the data in the recordset include the milliseconds?
On Error Resume Next
Dim sPassword
Dim sUserID
Dim sDefaultLib
Dim sSystem
Dim cs
Dim rc
Dim objIEDebugWindow
sDefaultLib = *library*
sUserID = *userid*
sPassword = *password*
sSystem = *system*
cs = *connectionString*
Set con = CreateObject("ADODB.Connection")
Set data = CreateObject("ADODB.Recordset")
con.Open cs, sUserID, sPassword
rc = con.State
If (rc = 1) Then
strQuery = "SELECT * FROM Library.Table FETCH FIRST 15 ROWS ONLY FOR READ ONLY WITH UR"
data.CursorLocation = adUseClient
data.Open strQuery, con
Set filsSysObj = CreateObject("Scripting.FileSystemObject")
Dim theYear
Dim theMonth
Dim theDay
Dim mDate
mDate = Date()
theYear = DatePart("yyyy", mDate)
theMonth = Right(String(2, "0") & DatePart("m", mDate), 2)
theDate = Right(String(2, "0") & DatePart("d", mDate), 2)
mDate = theYear & theMonth & theDate
Set csvFile = filsSysObj.OpenTextFile("C:\SampleFile_" & mDate & ".csv", 8, True)
columnCount = data.Fields.Count
Set i = 0
For Each field In data.Fields
i= i + 1
If (i <> columnCount) Then
csvFile.Write Chr(34) & field.Name & Chr(34) & ","
Else
csvFile.Write Chr(34) & field.Name & Chr(34)
End If
Next
csvFile.Write vbNewLine
End If
rowCount = data.RecordCount
row = 0
Dim row
Dim column
Dim resultsArray
Dim dateArray
resultsArray = data.GetRows
debug "hi"
i = 0
Do Until i>5
MsgBox(i)
i = i + 1
'debug "in"
'Dim value
'Dim dArray()
'debug "in"
'value = Chr(34) & CStr(data.Fields(17).Value) & Chr(34) & ","
'dArray = additem(dArray, value)
'data.MoveNext
'dateArray = dArray
Loop
debug "out"
For row = 0 To UBound(resultsArray, 2)
For column = 0 To UBound(resultsArray, 1)
If row = UBound(resultsArray, 2) And column = UBound(resultsArray, 1) Then
csvFile.Write Chr(34) & resultsArray(column, row) & Chr(34)
Else
If column = 0 Then
csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
ElseIf column = 19 Then
csvFile.Write Chr(34) & FormatDateTime(resultsArray(column, row),4) & Chr(34) & ","
ElseIf column = 18 Then
csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
'ElseIf column = 17 Then
'csvFile.Write Chr(34) & formatDate(resultsArray(column, row)) & Chr(34) & ","
Else
csvFile.Write Chr(34) & resultsArray(column, row) & Chr(34) & ","
End If
End If
Next
csvFile.Write vbNewLine
Next
csvFile.close
'----------------------Helper Functions are below-----------------------------
Sub Debug(myText)
'Dim objIEDebugWindow must be defined globally
'Call like this "Debug variableName"
'Uncomment the next line to turn off debugging
'Exit Sub
If Not IsObject(objIEDebugWindow) Then
Set objIEDebugWindow = CreateObject("InternetExplorer.Application")
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = "<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = objIEDebugWindow.Document.Body.InnerHTML & myText & "<br>" & vbCrLf
End Sub
Function formatDate(sDate)
Dim theYear
Dim theMonth
Dim theDay
Dim formattedDate
theYear = Year(sDate)
theMonth = Right(String(2,"0") & DatePart("m", sDate),2)
theDay = Right(String(2,"0") & DatePart("d", sDate),2)
formattedDate = theYear & "-" & theMonth & "-" & theDate
formatDate = formattedDate
End Function
The only field I am having issues with is field 17 of the recordset.
It is a timestamp datatype from a DB2 database.
The issue was the format is a timestamp in DB2 database. When i pull into a recordset it loses the milliseconds. My solution was to modify the query to add an extra row that pulls in only milliseconds and then later concatenate that back to the date. Please see below. Thanks for everyones help.
if(rc = 1) then
logFile.write FormatDateTime(Now(), 3) & ": Database connection successful" & vbNewLine
logFile.write FormatDateTime(Now(), 3) &": Default Library: " & sDefaultLib & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": Signed into server as: " & sUserID & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": System: " & sSystem & vbNewLine
strQuery = "SELECT ws_date, groupcd, userid, firstname, lastname, clientcd, unitcd, categorycd, category, activity, wrktype, subwrktype, step_begin, step_end, report_indicator, report_indicator, count, event_dattim, key_date, key_time, key_milsec, microsecond(event_dattim) FROM *Library.Name* FOR READ ONLY WITH UR"
data.CursorLocation = adUseClient
data.open strQuery, con
if data.EOF then
logFile.write FormatDateTime(Now(), 3) & ": The query returned no data"
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". There was no worksteps file created. ----------------" & vbNewLine
logFile.close
end if
columnCount = data.Fields.Count
columnCount = columnCount - 1
Set filsSysObj = CreateObject("Scripting.FileSystemObject")
Set csvFile = filsSysObj.OpenTextFile("C:\VBScript\Dailys\" & fname, 8, True)
set i = 0
for each field in data.Fields
i= i + 1
if i < columnCount then
csvFile.Write chr(34) & field.name & chr(34) & ","
elseif i = columnCount then
csvFile.Write chr(34) & field.name & chr(34)
else
exit for
end if
next
csvFile.Write vbNewLine
else
logFile.write FormatDateTime(Now(), 3) & ": Database connection was unsuccessful. Database Connection Return Code: " & rc
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". ----------------" & vbNewLine
logFile.close
csvfile.close
wscript.quit
end if
dim row
dim column
dim resultsArray
resultsArray = data.GetRows
dim arrayRows
arrayRows = ubound(resultsArray, 2)
if arrayRows <> 0 then
logFile.write FormatDateTime(Now(), 3) & ": " & (arrayRows + 1) & " rows were successfully read into the array for file " & fname & vbnewline
for row = 0 to UBound(resultsArray, 2)
for column = 0 to (UBound(resultsArray, 1) - 1)
if row = Ubound(resultsArray, 2) and column = (ubound(resultsArray, 1) - 1) then
csvFile.Write chr(34) & resultsArray(column, row) & chr(34)
else
if column = 0 then
csvFile.Write chr(34) & formatDate(resultsArray(column, row)) & chr(34) & ","
elseif column = 19 then
csvFile.Write chr(34) & FormatDateTime(resultsArray(column, row),4) & chr(34) & ","
elseif column = 18 then
csvFile.Write chr(34) & formatDate(resultsArray(column, row)) & chr(34) & ","
elseif column = 17 then
Dim fDate
fDate = formatDate(resultsArray(column, row)) & " " & FormatDateTime(resultsArray(column, row),4) & ":" & second(resultsArray(column,row)) & "." & resultsArray((ubound(resultsArray, 1)), row)
csvFile.Write chr(34) & fDate & chr(34) & ","
else
csvFile.Write chr(34) & resultsArray(column, row) & chr(34) & ","
end if
end if
next
csvFile.Write vbNewLine
next
logfile.write FormatDateTime(Now(), 3) & ": " & (row) & " rows have been written to " & fname &vbNewLine
else
logFile.write FormatDateTime(Now(), 3) & ": There was no data in the query results array for file " & fname & vbNewLine
logFile.write FormatDateTime(Now(), 3) & ": ---------------- The script DailyWorkstepReport.vbs file was abended at " & Now() &". ----------------" & vbNewLine
logfile.close
csvfile.close
wscript.quit
end if
csvFile.close
logfile.write "---------------- DailyWorkstepReport.vbs script successfully ended at " & Now() & "----------------" & vbNewLine
logfile.close
wscript.quit
REM ----------------------Helper Functions are below-----------------------------
Sub Debug( myText )
'Dim objIEDebugWindow must be defined globally
'Call like this "Debug variableName"
'Uncomment the next line to turn off debugging
'Exit Sub
If Not IsObject( objIEDebugWindow ) Then
Set objIEDebugWindow = CreateObject( "InternetExplorer.Application" )
objIEDebugWindow.Navigate "about:blank"
objIEDebugWindow.Visible = True
objIEDebugWindow.ToolBar = False
objIEDebugWindow.Width = 200
objIEDebugWindow.Height = 300
objIEDebugWindow.Left = 10
objIEDebugWindow.Top = 10
Do While objIEDebugWindow.Busy
WScript.Sleep 100
Loop
objIEDebugWindow.Document.Title = "IE Debug Window"
objIEDebugWindow.Document.Body.InnerHTML = "<b>" & Now & "</b></br>"
End If
objIEDebugWindow.Document.Body.InnerHTML = objIEDebugWindow.Document.Body.InnerHTML & myText & "<br>" & vbCrLf
End Sub
function formatDate(sDate)
Dim theYear
Dim theMonth
Dim theDay
Dim formattedDate
theYear = Year(sDate)
theMonth = Right(String(2,"0") & DatePart("m", sDate),2)
theDay = Right(String(2,"0") & DatePart("d", sDate),2)
formattedDate = theYear & "-" & theMonth & "-" & theDate
formatDate = formattedDate
end function
I have a combo box on my form with the choice of choosing organization 10, 20, 30....
I have added ALL to the combo list box, but am having trouble implementing an all statement in VBA. Below is the case statement I have to get info from organizations 10, 20, 30. How do I get ALL to generate??
Case Is = 1
If cboOrg.ListIndex < 0 Then
Call msg("Please select your organization!")
Exit Sub
End If
sQ = sQ & " CC LIKE '" & cboOrg.Value & "*'"
ORGCC = Trim(cboOrg.Value)
I think you should only generate the WHERE/AND-clause, when value is not "ALL" (instead of your current assignment):
If (cboOrg.Value <> "ALL") Then
sQ = sQ & " AND CC LIKE '" & cboOrg.Value & "*'"
End If
To make it work without changing code before (generating AND or WHERE), you could try:
If (cboOrg.Value <> "ALL") Then
sQ = sQ & " CC LIKE '" & cboOrg.Value & "*'"
Else
sQ = sQ & " 1=1"
End If
Do you really need the LIKE (does CC only start with the value selected) or would
WHERE CC = '" & cboOrg.Value & "'" be sufficient?
Private Sub cmdGo_Click()
Dim db As Database, rs As Recordset, sQ As String
Dim oXL, oExcel As Object
Set oXL = CreateObject("Excel.Application")
fPath = "\\firework\mmcfin\123files\Edmond\Lawson Query\Log\"
myTime = Now()
myFile = Environ("UserName") & "-" & Environ("ComputerName") & "-" & Replace(Replace(Replace(Trim(myTime), "/", "-"), " ", "-"), ":", "-")
pTitle = "Lawson Queries"
Set db = CurrentDb
Select Case cboActBud.ListIndex
Case Is < 0
Call msg("Please select your query type first: Actual or Budget!")
Exit Sub
Case Is = 0
sQ = "SELECT * INTO [" & myFile & "] FROM ACT"
toAdd = "WHERE"
Case Is = 1
sQ = "SELECT * INTO [" & myFile & "] FROM BUD"
If cboBucket.ListIndex < 0 Then
Call msg("Please select your budget bucket!")
Exit Sub
Else
toAdd = "WHERE BUDGET_NBR = " & cboBucket.Value & " AND"
End If
End Select
myAcctLo = txtACCT1.Value
myAcctHi = txtACCT2.Value
If IsNull(myAcctLo) Or myAcctLo < 1000 Or myAcctLo > 99999 Then
Call msg("Account number is missing or invalid!")
Exit Sub
End If
If IsNull(myAcctHi) Then
myAcctHi = myAcctLo
End If
If myAcctLo > myAcctHi Then
Call msg("Account range is invalid!")
Exit Sub
End If
If myAcctLo < 90000 And myAcctHi >= 90000 Then
Call msg("You can query amounts or units; but, not both at the same time!")
Exit Sub
End If
Select Case myAcctLo
Case Is < 90000: sQ = sQ & "AMT " & toAdd
Case Is >= 90000: sQ = sQ & "UNT " & toAdd
End Select
Select Case cboLevel.ListIndex
Case Is < 0
Call msg("Please select your reporting level: Cost Center or Organization!")
Exit Sub
Case Is = 0
If IsNull(txtCC) Then
Call msg("Please enter your cost center!")
Exit Sub
End If
sQ = sQ & " CC = " & txtCC.Value
ORGCC = Trim(txtCC.Value)
Case Is = 1
If cboOrg.ListIndex < 0 Then
Call msg("Please select your organization!")
Exit Sub
End If
sQ = sQ & " CC LIKE '" & cboOrg.Value & "*'"
ORGCC = Trim(cboOrg.Value)
If (cboOrg.Value <> "All") Then
sQ = sQ & " CC LIKE '" & cboOrg.Value & "*'"
Else
sQ = sQ & " 1=1"
End If
End Select
If cboYear.ListIndex < 0 Then
Call msg("Please select an year!")
Exit Sub
End If
sQ = sQ & " AND FY = " & cboYear.Value & " AND (ACCT >= " & myAcctLo & " AND ACCT <= " & myAcctHi & ")"
DoCmd.Hourglass True
db.Execute sQ
sQ = "INSERT INTO tblLog (UserName, ComputerName, DateAndTime, ORGORCC, ACCT1, ACCT2, BUDGET, FY) VALUES ('" & _
Environ("UserName") & "','" & Environ("ComputerName") & "',#" & myTime & "#," & ORGCC & "," & myAcctLo & _
"," & myAcctHi & "," & IIf(cboBucket.ListIndex < 0, 0, Trim(cboBucket.Value)) & "," & Trim(cboYear.Value) & ")"
db.Execute sQ
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, myFile, fPath & myFile, True
With oXL
.Visible = True
.Workbooks.Open (fPath & myFile)
End With
Set oXL = Nothing
DoCmd.Hourglass False
db.Close