I have a general question. I think it is not code related.
I have a small access program using forms, SQL and VBA.
The VBA mainly calculate pretty simple things, but with a lot of data and some SQL runs. I have a status bar where i can see "percentage done".
I start the script by clearing all tables and after that running all queries to make sure they're empty.
I then run through the data. It works good.
It takes around 2 mins.
I then do it again.
But now it takes 10 mins. For the same procedure.
If i restart access, it takes 2 mins the first time, then 10 mins afterwards.
When i restart access, the tables are still filled. So it is not because they are empty.
Is there a command to clear all memory or whatever might be needed?
Any suggestions?
The code that runs 10x slower:
For counter = 1 To n_bins
Application.Echo False
DoCmd.OpenQuery "q_PowerBinned"
If DCount("*", "q_PowerBinned") = 0 Then
DoCmd.OpenQuery "q_000"
DoCmd.RunSQL "DELETE * FROM q_000"
DoCmd.Close
strTMP = (counter - 1) * [Forms]![f_main]![PowerBinCombo] & " - " & counter * [Forms]![f_main]![PowerBinCombo] & " kW"
strSQL = "INSERT INTO q_000 (Bin, Zero1, Zero2, Zero3, Zero4, Zero5) VALUES ('" & strTMP & "','0','0','0','0','0');"
DoCmd.RunSQL strSQL
DoCmd.OpenQuery "q_Move000"
DoCmd.Close
Else
DoCmd.Close
End If
DoCmd.OpenQuery "q_Average_Temp"
DoCmd.Close
DoCmd.OpenQuery "q_MoveAverage"
DoCmd.OpenQuery "q_PowerBinned_VG"
If DCount("*", "q_PowerBinned_VG") = 0 Then
DoCmd.OpenQuery "q_000_VG"
DoCmd.RunSQL "DELETE * FROM q_000_VG"
DoCmd.Close
strTMP = (counter - 1) * [Forms]![f_main]![PowerBinCombo] & " - " & counter * [Forms]![f_main]![PowerBinCombo] & " kW"
strSQL = "INSERT INTO q_000_VG (Bin, Zero1, Zero2, Zero3, Zero4, Zero5) VALUES ('" & strTMP & "','0','0','0','0','0');"
DoCmd.RunSQL strSQL
DoCmd.OpenQuery "q_Move000_VG"
DoCmd.Close
Else
DoCmd.Close
End If
DoCmd.OpenQuery "q_Average_Temp_VG"
DoCmd.Close
DoCmd.OpenQuery "q_MoveAverage_VG"
Application.Echo True
' Theoretical of Measured Power Curve
Percentage = ((counter) / (n_bins)) * 100
strStatus = "Binned " & Percentage & " %"
Call dsp_progress_AfterUpdate
Me.Refresh
dsp_progress.SetFocus
dsp_progress.SelStart = 0
dsp_progress.SelLength = 0
DoEvents
Next counter
This happens for one of my access databases. I find that if I do a compact & repair after the appropriate tables have been emptied, the vba run-time returns to the short time again. Not the most elegant of solutions I must admit.
Related
Hello ive got a client/server 2d mmorgp game plaing by us frinds and due to to many copies of the client ive tried to reduce the client to be opened to 2 clients per device but is not per device its on the network 2 clients . maybe i do somewhere mistake.
Sub ConnectionRequestCon(ByVal requestID As Long)
On Error Resume Next
Dim check As Integer
Dim LoggedOn As Integer
Dim NewIndex As Integer
Dim RandomCheck As Integer
NewIndex = GetFreeIndex
LogOutProcedure NewIndex
RandomizeConLandLaunch NewIndex
Load Main.Server(NewIndex)
Load Main.EngageTimer(NewIndex)
Main.Server(NewIndex).Accept requestID
AddServerLogText NewIndex & ": Connected [" & Main.Server(NewIndex).RemoteHostIP & "]"
RandomCheck = RandomNumber(1000, 30000)
SetConAuthNumber NewIndex, RandomCheck
Main.Server(NewIndex).SendData "1,Welcome To Xiaspora - " & TotalLogedInUsers & " Users Online" & Chr(13) & "34," & RandomCheck & Chr(13)
DoEvents
Do
check = check + 1
If Main.Server(check).State = 7 And Main.Server(check).RemoteHostIP = Main.Server(NewIndex).RemoteHostIP Then LoggedOn = LoggedOn + 1
Loop Until check = Main.Server.Count
If LoggedOn >= 4 Then CloseCon NewIndex 'with the number 4 reduce the clients per device . when is 7 is unlimited
End Sub
You are looping check from 1 to Main.Server.Count and check each Main.Server(check).State but you probably have unloaded socket controls already.
You have On Error Resume Next at the top of the code but consider that similar code like this
Dim lCount As Long
On Error Resume Next
If 1 / 0 > 0 Then lCount = lCount + 1
Debug.Print lCount
. . . prints 1 i.e. from If expression OERN gets "next" statement inside the If, no matter that it's on the same line as the If expression.
Now consider what happens when Main.Server(check).State is checked on an unloaded control. Because of the OERN this one will be counted towards LoggedOn which is clearly not what you want to do.
With OERN in this case you might want to reverse the If expression like this
If Main.Server(check).State <> 7 Then
'--- do nothing
ElseIf Main.Server(check).RemoteHostIP = Main.Server(NewIndex).RemoteHostIP Then
LoggedOn = LoggedOn + 1
End If
. . . so that when accessing Main.Server(check).State bombs out it "enters" the If block and there is nothing to do there.
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
I am trying to create a script that will look at a specific .txt file on the local computer, get it's DateLastModified attribute, and compare it to the last/previous value when it was last checked (in a loop, every 1-2 seconds).
The loop (running every second) would increment a counter, and if the counter reaches a limit (say 10 seconds), a section of code would perform a task of "kill/terminate" a specific process/.exe that is likely hung up, and restart it.
I've found some pretty good samples of .vbs online that use subscription events, I don't think this is the route I want/need to go, as the script actually needs to be continuously running and not asynchronously only when the specific file is modified.
Edit: I am looking for a VBScript that provides a "watchdog" function, by monitoring a .txt file for modifications. The script should run a loop every second that checks for modifications, and if no modifications, increments a counter. Once the counter reaches a limit (10 seconds?) it would terminate a fixed process (hardcoded as a parameter in the VBScript), and then relaunch the process (path to the process as a parameter in the VBScript).
I haven't found a good example to share thus far. I've been playing with other examples that utilize the objWMIService.ExecNotificationQuery(Query) which seems cool in that little overhead is used (asynchronous in nature) -- it does not appear to fit my needs as described above.
If I must share what I've found and been toying with... OK... here it is:
intInterval = "1"
strDrive = "C:"
strFolder = "\\Project\\"
strComputer = "."
intTmrVal = 0
Set objWMIService = GetObject( "winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2" )
strQuery = "Select * From __InstanceOperationEvent" _
& " Within " & intInterval _
& " Where Targetinstance Isa 'CIM_DataFile'" _
& " And TargetInstance.Name='C:\\Project\\test.txt'"
Set colEvents = objWMIService.ExecNotificationQuery(strQuery)
Do
Set objEvent = colEvents.NextEvent()
Set objTargetInst = objEvent.TargetInstance
Select Case objEvent.Path_.Class
Case "__InstanceCreationEvent"
WScript.Echo "Created: " & objTargetInst.Name
Case "__InstanceDeletionEvent"
WScript.Echo "Deleted: " & objTargetInst.Name
Case "__InstanceModificationEvent"
Set objPrevInst = objEvent.PreviousInstance
For Each objProperty In objTargetInst.Properties_
If objProperty.Value <> objPrevInst.Properties_(objProperty.Name) Then
WScript.Echo "Changed: " & objTargetInst.Name
WScript.Echo "Property: " & objProperty.Name
WScript.Echo "Previous value: " & objPrevInst.Properties_(objProperty.Name)
WScript.Echo "New value: " & objProperty.Value
End If
Next
End Select
'Count how many times it has been modified // just playing with a counter
If objEvent.TargetInstance.LastModified <> objEvent.PreviousInstance.LastModified Then
intTmrVal = intTmrVal+1
WScript.Echo "Changed: " & intTmrVal & " times"
WScript.Echo
End If
Loop
An easy way is to directly set the timeout in the WMI request for the next event
Option Explicit
Const MONITOR_FILE = "c:\temp\test.txt"
Const MONITOR_LIMIT = 10
Dim wmi
Set wmi = GetObject( "winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2" )
Dim query
query = "SELECT * FROM __InstanceOperationEvent WITHIN 1 " _
& " WHERE TargetInstance ISA 'CIM_DataFile' " _
& " AND TargetInstance.Name='" & Replace(MONITOR_FILE, "\", "\\") & "'"
Dim colEvents
Set colEvents = wmi.ExecNotificationQuery( query )
Dim currentEvent
Do
' Flag value
Set currentEvent = Nothing
' Try to get the next event with a timeout limit
' If a timeout happens we need to catch raised error
On Error Resume Next
Set currentEvent = colEvents.NextEvent( MONITOR_LIMIT * 1000 )
On Error GoTo 0
' If there is not an event there was a timeout
If currentEvent Is Nothing Then
Exit Do
End If
Loop
WScript.Echo "File has not been changed for " & MONITOR_LIMIT & " seconds."
Event watchers react to events when they occur. You, however, want to react to events that are not occurring (namely a file not getting modified). You cannot use an event watcher for that for obvious reasons.
What you need is code that checks the file's last modified date
path = "C:\Project\test.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
ts = fso.GetFile(path).DateLastModified
and then kills a given process if that timestamp is more than x seconds/minutes
pname = "foo.exe"
wmi = GetObject("winmgmts://./root/cimv2")
qry = "SELECT * FROM Win32_Process WHERE Name='" & pname & "'"
If DateDiff("s", ts, Now) > 10 Then
For Each p In wmi.ExecQuery(qry)
p.Terminate
Next
End If
However, the Windows Task Scheduler doesn't support your desired granularity of running the task every second (or every 2 seconds). And even if it did, spawning a new process every second wouldn't be very good for system performance in the first place. You can set a daily schedule and then instruct Task Scheduler to re-run the task every 5 minutes for the duration of a day. The rest you need to account for in your script.
Define a 5 minute timeout and re-run your check in a loop until that timeout expires:
interval = 2 'seconds
timeout = 5 'minutes
endtime = DateAdd("n", timeout, Now)
sleeptime = interval * 1000 'milliseconds
Do
'check and process handling go here
WScript.Sleep sleeptime
Loop Until Now >= endtime
Since fso and wmi can be re-used don't waste resources by re-defining them over and over again inside the loop. Define them just once at the beginning of the script.
I need some assistance with outputting an error in CMD.
We have a timesheet system that is failing to add holidays into the users time sheets, it's done via a script. here is the portion of the script in question.
sql = "select h_user,h_date1,h_hrs,h_approved,hol_default from holidays,hol_type,logins_users where userid=h_user and h_type=hol_id and h_date1='" & today & "' order by h_type desc"
'WScript.Echo Sql
ar.Open Sql, cnn ', adOpenForwardOnly, adLockReadOnly, adCmdText
If Not (ar.EOF And ar.BOF) Then 'found some holidays
ar.movefirst()
While Not ar.EOF
count = count + 1
user = ar.Fields("h_user").Value
datestr = ar.Fields("h_date1").Value
hours = ar.Fields("h_hrs").Value
approved = ar.Fields("h_approved").Value
defaulthours = ar.Fields("hol_default").Value
If hours = 8 Then actualhours = defaulthours
If hours = 4 Then actualhours = defaulthours / 2
If hours = 0 Then actualhours = 0
sqlstr = "select * from timesheets where ts_user=" & user & " and ts_hrs in(" & hours & "," & defaulthours &") and ts_date='" & today & "' and ts_job=20"
ar1.Open sqlstr, cnn
If Not (ar1.EOF And ar1.BOF) Then
'record exists
sqlstr = "update timesheets set ts_eduser=0,ts_eddate=now() where ts_user=" & user & " and ts_hrs=" & actualhours & " and ts_date='" & today & "' and ts_job=20"
Else
'no record
sqlstr = "insert into timesheets (ts_user,ts_date,ts_hrs,ts_approved,ts_job,ts_cruser,ts_crdate) values (" & user & ",'" & today & "'," & actualhours & "," & approved & ",20,0,Now())"
End If
ar1.Close()
cnn.Execute("insert into tracking (t_user,t_query) values (0,'" & addslashes(sqlstr) & "')")
cnn.Execute(sqlstr)
ar.MoveNext()
Wend
End If
ar.Close
Next
message = message & count & " holidays entries added" & vbCrLf
count = 0
Set ar1 = Nothing
Set ar2 = Nothing
Set ar1 = CreateObject("ADODB.RecordSet")
Set ar2 = CreateObject("ADODB.RecordSet")
For n = 0 To 28
daystr = DateAdd("d", n, Now())
today = Mid(daystr, 7, 4) & "-" & Mid(daystr, 4, 2) & "-" & Left(daystr, 2)
What I need to do is specifically output the results of defaulthours in a cmd window to allow me to inspect the error in the data it's retrieving.
I realise it's a WScript.Echo command but I've tried several variations and it stops the script from running.
Could someone point me in the right direction?
Run the script with cscript.exe instead of the default interpreter (wscript.exe).
cscript //NoLogo C:\path\to\your.vbs
cscript.exe prints WScript.Echo messages to the console instead of displaying message popups.
Alternatively you could replace WScript.Echo with WScript.StdOut.WriteLine, which will require cscript and raise an error otherwise (because WScript.StdOut is not available in wscript).
To get around a runtime error I need to read from an SAP table AGR_1251 in chunks using VBScript when I run a (SE16 | AGR_1251) query. I get this error TSV_TNEW_PAGE_ALLOC_FAILED - No more storage space available for extending an internal table.
As a work around, we manually copy 750 roles from the user by roles at a time, add a "*" to those that end with a certain character, then paste this back into the multiple select dialog to get the the AGR_1251 extract results in chunks.
I can't figure out how to do this in vbscript. How do I programmatically chunk this data? Ideally I would deduplicate it as well, but its not required.
The code has to run on both vbscript and in javascript, so I can't use excel or other windows tools like wscript. The best idea I have so far is to scroll through and copy just the roles to a file, read them back into an array and dedupe as I read them, then alter them, then loop back through the list to chuck out the results.
This is WAY above my nearly nonexistant vbscript skills. I can't be the only one who has had this problem. Can anyone point me to examples code that does this?
I'm open to suggestions on a better approach as well. I think my solution is fugly to say the least.
OK, this code is fugly with some unneeded variables, but it works.
Sub Save_AGR_1251s(Tcodes_array,Chunk_size)
Go_AGR_1251
writelog("Processing " & ubound(Tcodes_array) & " Tcodes in AGR_1251...")
k = 0
s = Chunk_size
max = ubound(Tcodes_array)
part = 0
roles_processed = 0
For i = 0 To max Step s
Go_AGR_1251
session.findById("wnd[0]/usr/txtMAX_SEL").text = ""
session.findById("wnd[0]/usr/txtMAX_SEL").setFocus
session.findById("wnd[0]/usr/txtMAX_SEL").caretPosition = 11
session.findById("wnd[0]/usr/btn%_I1_%_APP_%-VALU_PUSH").press
k = i + s
counter = 0
part = part + 1
If k > max Then k = max End If
For j = i To k-1
' writelog("Save_AGR_1251s Processing Tcode: " & Tcodes_array(j))
If (Tcodes_array(j) <> "STMS" or Tcodes_array(j) <> "SCC4") Then
'NOTE: The slow insert is used on XXXX Prod as a work around to odd UI behavior - change with caution - But SLOW!!
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,7]").setFocus
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,7]").text = Tcodes_array(j)
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,7]").caretPosition = 1
'VKey 13 = Shift-F1 (insert new row)
session.findById("wnd[1]").sendVKey 13
If Debug_flag = True Then
writelog("i=" & i & " j=" & j & " k=" & k & " s=" & s &" max=" & max &" counter= " & counter)
writelog("part =" & part & " roles= " & roles & "roles_processed="& roles_processed & " Tcodes_array= " & Tcodes_array(j))
End If ' Debug_flag
counter = counter + 1
roles_processed = roles_processed + 1
End If ' Tcodes_array
Next 'for j to k
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,1]").setFocus
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1,1]").caretPosition = 13
session.findById("wnd[1]/tbar[0]/btn[8]").press
session.findById("wnd[0]").sendVKey 8
session.findById("wnd[0]").sendVKey 45
session.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").select
session.findById("wnd[1]/usr/subSUBSCREEN_STEPLOOP:SAPLSPO5:0150/sub:SAPLSPO5:0150/radSPOPLI-SELFLAG[1,0]").setFocus
session.findById("wnd[1]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ctxtDY_PATH").text = dir
file_name = AGR_1251_filename & "_Part_" & part & c_dash & postfix & Datafile_ext
session.findById("wnd[1]/usr/ctxtDY_FILENAME").text = file_name
writelog("Saving file: " & dir & file_name)
session.findById("wnd[1]/usr/ctxtDY_FILE_ENCODING").text = File_encoding
session.findById("wnd[1]/usr/ctxtDY_PATH").setFocus
session.findById("wnd[1]/usr/ctxtDY_PATH").caretPosition = 16
session.findById("wnd[1]").sendVKey 11
Go_Home
Next ' For i
End Sub
Note that you can do this much faster on most systems by simply doing this
for i = 1 to 100
session.findById("wnd[1]/usr/tabsTAB_STRIP/tabpSIVA/ssubSCREEN_HEADER:SAPLALDB:3010/tblSAPLALDBSINGLE/ctxtRSCSEL_255-SLOW_I[1," & 7 & "]").text = "Test " & i
next 'for i
I am running a vb6 program that is looping through many records in a database table and entering a date into a field. This will take many hours to run.
I am noticing that the number of records in the table is increasing by 1 every few seconds and then reducing by 1 (going back to the original count). Is there a reason for this?
I am using a VB6 recordset and the update function i.e. rs.update. I am not inserting any new records.
The code is as follows:
rs.Open "select reference,value1,datefield from datetable where field1 = 'value1' " & _
"order by reference", objAuditCon.ActiveCon, adOpenStatic, adLockPessimistic
Do While Not rs.EOF
intReadCount = intReadCount + 1
DoEvents
If Not IsNull(rs("value1")) Then
testArray = Split(rs("value1"), ",")
rs2.Open "SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'", objSystemCon.ActiveCon, adOpenStatic, adLockReadOnly
If rs2.EOF Then
End If
If Not rs2.EOF Then
rs("DateField") = Format$(rs2("Date"), "dd mmm yy h:mm:ss")
rs.Update
intWriteCount = intWriteCount + 1
End If
rs2.Close
Else
End If
rs.MoveNext
Loop
rs.Close
Well you can greatly reduce your SQL work here.
If Not IsNull(rs("value1")) Then
testArray = Split(rs("value1"), ",")
rs2.Open "SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'", objSystemCon.ActiveCon, adOpenStatic, adLockReadOnly
If rs2.EOF Then
End If
If Not rs2.EOF Then
rs("DateField") = Format$(rs2("Date"), "dd mmm yy h:mm:ss")
rs.Update
intWriteCount = intWriteCount + 1
End If
rs2.Close
You're essentially, it looks to me(I haven't used VB6 & ADO in 10 years), loading up your record initial recordset, checking a value, and if that value is not null running a second select THEN updating the recordset....
You can instead of doing all this just create a command object
Declare these before your loops
dim objComm
set objComm = Server.CreateObject("ADODB.Command")
objComm.ActiveConnection = objSystemCon.ActiveCon 'I think this is your connn.
objComm.CommandType = 1 'adCmdText
Use this in your loop
objComm.CommandText = "UPDATE DateTable SET DateField = (SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'")
objComm.Execute
Rather than doing a 2nd discreet select, pulling the data in, then doing an update and pushing it back out just push out an update statement. This should speed up the processing of your records.....I know i used to write stuff in VB6 like this a long while back :)
So your code should now read like
dim objComm
set objComm = Server.CreateObject("ADODB.Command")`
objComm.ActiveConnection = objSystemCon.ActiveCon 'I think this is your connn.
objComm.CommandType = 1 'adCmdText
rs.Open "select reference,value1,datefield from datetable where field1 = 'value1' " & _
"order by reference", objAuditCon.ActiveCon, adOpenStatic, adLockPessimistic
Do While Not rs.EOF
intReadCount = intReadCount + 1
DoEvents
If Not IsNull(rs("value1")) Then
testArray = Split(rs("value1"), ",")
objComm.CommandText = "UPDATE DateTable SET DateField = (SELECT Date FROM TBL_TestTable WHERE Record_URN = '" & testArray(1) & "'")
objComm.Execute
End If
rs.MoveNext
Loop
rs.Close
your select statement is still there as you can see, it's a sub select now, the advantage being huge, you're not drawing records to the server, then updating them. You're sending the server a statement to do the updating. You're cutting your trips in half.
Hope this made sense.
Simple answer: take out the DoEvents statement. If you are using it to get screen refresh, the periodically do a manual refresh of your GUI after, say, 1000 iterations of the loop.
The reason why this may be causing an issue is that other code you may have no control over might be being executed when you call DoEvents.