Why do I get a "necessary object" error on objShell? - html

I don't know why I'm getting an error on the Set objShell = statement of this VBS code (it's in an HTML). I'm working on a .HTA launcher for a game named Doom and this VBScript serves to select the game and launch it with some parameters.
Dim pwad, warp, skill, execDoom, execPwad, execWarp, execSkill, rep, fso, file, OpFScript, WScript, objShell
Set objShell = WScript.CreateObject("WScript.Shell")
Set pwad = document.GetElementById("inpFILE")
Set warp = document.GetElementById("inpMAP")
Set skill = document.GetElementById("inpSKILL")
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.OpenTextFile("C:\ZDLRemastered\launcher\ScriptOpFile.txt", 1)
OpFScript = file.ReadAll
Function GetFileDlgEx(sIniDir,sFilter,sTitle)
Set oDlg = CreateObject("WScript.Shell").Exec("mshta.exe & OpFScript")
oDlg.StdIn.Write "var iniDir='" & sIniDir & "';var filter='" & sFilter & "';var title='" & sTitle & "';"
GetFileDlgEx = oDlg.StdOut.ReadAll
End Function
sFilter = "Doom Archive (*.wad)|*.wad|"
sTitle = "Select a Doom IWAD"
rep = GetFileDlgEx(Replace(sIniDir,"\","\\"),sFilter,sTitle)
execDoom = "C:\ZDLRemastered\gzdoom\gzdoom.exe -config C:\ZDLRemastered\gzdoom\gzconfig.ini -iwad "
execPwad = " -file "
execWarp = " -warp "
execSkill = " -skill "
objShell.Run execDoom & Chr(34) & rep & Chr(34) & execPwad & Chr(34) & pwad & Chr(34) & execWarp & Chr(34) & warp & Chr(34) & execSkill & Chr(34) & skill & Chr(34)
This is the error:
necessary object: " -

HTAs run in a different engine than regular VBScript (mshta.exe vs wscript.exe/cscript.exe). The HTA engine does not provide an intrinsic WScript object, hence WScript.CreateObject() or WScript.Sleep() or WScript.Quit() won't work.
That intrinsic object isn't required for creating objects, though, since VBScript also has a global function CreateObject() (which is not the same as WScript.CreateObject()).
Change this:
Set objShell = WScript.CreateObject("WScript.Shell")
into this:
Set objShell = CreateObject("WScript.Shell")
and the problem will disappear.

Related

Why is VBA code slowing down when processing larger tables

I got problem with one of my subroutines, which job is to convert any passed ListObject (ussually generated by powerquery) into multiple MySQL queries, then send them to database. Queries and progress are shown on userform, that refresh with every query. My problem is that for some reason with some large tables, code starts out very quickly, but at some point it instantly slows down to fraction of speed it started and excel ram usage is increasing by +-1MB/s while running, and after code finish, it stays there.
With smaller tables (low column count, or small values in cells) it can process tens of thousands rows very fast without slowing, but problem comes with some large tables (either higher column count, or big values in cells, for ex. long strings etc...) after like 3k rows.
This sub is responsible for looping thru table, and building insert queries, then every few rows (depending on query length) calls function, that can send any query into selected DB. The problem is in "For i" loop, but i including whole code here.
Public Sub UploadniPayload(DBtabulka As String, Zdroj As ListObject, Optional Databaze As String = "tesu")
If ErrorMode = False Then On Error Resume Next
Dim Prikaz As String, Radek As String, Payload As String, i As Long, x As Long, PocetRadku As Long, PocetSloupcu As Long, DBsloupce As Long
Call VyplnNetInfo(DBIP)
AutoUploader.loading_sql.Value = 0
PocetRadku = Zdroj.DataBodyRange.Rows.Count
PocetSloupcu = Zdroj.DataBodyRange.Columns.Count
DBsloupce = DBPocetSloupcu(DBtabulka, Databaze)
If JeTabulkaPrazdna(Zdroj) = False Then
If (Zdroj.DataBodyRange.Columns.Count + 1) = DBsloupce Then
'PROBLEM APPEARING IN THIS LOOP
For i = 1 To PocetRadku
For x = 1 To PocetSloupcu
If x <= 0 Then Exit For
If x = 1 Then
Payload = "'','" & Zdroj.DataBodyRange(i, x).Text & "'"
Else
Payload = Payload & ",'" & Zdroj.DataBodyRange(i, x).Text & "'"
End If
Next x
Radek = "(" & Payload & ")"
If Prikaz <> vbNullString Then Prikaz = Prikaz & ", " & Radek Else Prikaz = Radek
If i = PocetRadku Or Len(Prikaz) > 2500 Then
AutoUploader.loading_sql.Value = i / PocetRadku
AutoUploader.txtStatus.Caption = "Zpracovávám " & i & "/" & PocetRadku & " řádků"
Prikaz = "INSERT INTO `" & Databaze & "`.`" & DBtabulka & "` VALUES " & Prikaz
Call PrikazSQL(Prikaz, Databaze)
Prikaz = vbNullString
Payload = vbNullString
End If
Next i
Else
Call Zaloguj("System", "Error - počet sloupců v " & Zdroj.Name & " (" & PocetSloupcu & "+1 ID) nesouhlasí s počtem sloupců v " & DBtabulka & "(" & DBsloupce & ")", False)
End If
Else
Call Zaloguj("System", "Error - pokus o upload prázdné tabulky (" & Zdroj.Name & ") do DB (" & DBtabulka & ")", False)
End If
If AutoUploader.chb_Uklizecka.Value = True Then Call VycistiTabulku(Zdroj)
End Sub
And this is my function responsible for sending queries into database.
Sometimes i use it for pulling single value from database, so it acts as string, but when i need only insert, i just using Call. DBIP, DBUser and DBPass are global variables.
Public Function PrikazSQL(ByRef Prikaz As String, Optional Databaze As String = "tesu") As String
On Error GoTo ErrHandler
AutoUploader.IconDirectSQL.BackColor = vbGreen
AutoUploader.txtKUK.Value = Prikaz
'If ErrorMode = True Then Call Zasifruj
DoEvents
Dim Pripojeni As ADODB.Connection, RS As ADODB.Recordset
Set Pripojeni = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.RecordSet")
Pripojeni.Open "" & _
"DRIVER={MySQL ODBC 8.0 UNICODE Driver}" & _
";SERVER=" & DBIP & _
";DATABASE=" & Databaze & _
";USER=" & DBUser & _
";PASSWORD=" & DBPass & _
";Option=3"
With RS
.CursorLocation = adUseClient
.LockType = adLockBatchOptimistic
.Open Prikaz, Pripojeni
.ActiveConnection = Nothing
End With
Pripojeni.Close
Set Pripojeni = Nothing
If RS.Fields.Count > 0 Then PrikazSQL = RS(0)
Set RS = Nothing
AutoUploader.IconDirectSQL.BackColor = vbWhite
DoEvents
Exit Function
ErrHandler:
RS.ActiveConnection = Nothing
If Not Pripojeni Is Nothing Then
Pripojeni.Close
Set Pripojeni = Nothing
End If
If RS.Fields.Count > 0 Then PrikazSQL = RS(0)
Set RS = Nothing
AutoUploader.IconDirectSQL.BackColor = vbWhite
DoEvents
Call Debuger("ERROR:" & vbCrLf & Err.Description & vbCrLf & vbCrLf & "QUERY:" & vbCrLf & Prikaz, "PrikazSQL")
End Function
Code above is only part of the autonomous bot, on start it apply these settings:
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
DoEvents is used only for refreshing userform, instead of repaint.
I try to unload any object or variable, that i dont need, but i think i am missing something important. Any other part of code runs fine. Any help would be very appreciated.

Unable to run vbscript file due to access limit

I am trying to upload a file on HTML page, for which I need to run the vbascript saved on my desktop. But when I am executing the code its asking for admin permission and getting error as "Access Denied". So is there any way to run this file without but it should not break any policy and as I don't want to create any security issue.
Thanks in advance:)
Sub uploadFiles()
Dim ie As Object
Dim strFile As Variant
Dim strUploadFile As Variant
Dim objShell As Variant
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate "https://www.pdftoexcelconverter.net/"
ie.Visible = True
Application.Wait DateAdd("s", 5, Now)
strFile = "C:\Users\kiranm\Desktop\2019\FileUpload.vbs"
strUploadFile = "C:\Users\kiranm\Desktop\2019\fl0005.pdf"
Dim R_Shl As Double
Set objShell = CreateObject("WScript.Shell")
objShell.Run Chr(34) & strFile & Chr(34) & strUploadFile & Chr(34)
ie.document.getElementsByName("Filedata")(0).Click
Application.Wait DateAdd("s", 2, Now)
End Sub
Here is how
Chr(34) & strFile & Chr(34) & strUploadFile & Chr(34)
really looks like (this is from your code): "C:\Users\kiranm\Desktop\2019\FileUpload.vbs"C:\Users\kiranm\Desktop\2019\fl0005.pdf"
As you see, there are not enough double quotes and spaces.
And here is how
"wscript.exe" & strFile & " " & strUploadFile
look like (this is from your comment)
wscript.exeC:\Users\kiranm\Desktop\2019\FileUpload.vbs C:\Users\kiranm\Desktop\2019\fl0005.pdf
So, I would have tried to use this version:
Chr(34) & strFile & Chr(34) & " " & Chr(34) & strUploadFile & Chr(34)
in the code in post.

How do I overwrite a macro of a linked table in MS Access using VBA?

I have a split access database. The tables which reside in the backend have "Before Change" macros built into them (in the backend). I need to overwrite these macros with new ones. I have an XML file of the updated macro and am trying to use the code below to overwrite the macros. However, the code below puts the macro on my linked table in the frontend. I need the macro to update the macro on the table in the backend. Any and all help is much appreciated.
LoadFromText acTableDataMacro, "tblEXAMPLE", strXMLpath
I figured out how to do this.
Dim fso As Object
Dim oFile As Object
Dim strXML As String
Dim strXMLpath As String
Dim strBE As String
Dim accessApp As Access.Application
strXML = "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "UTF-16" & Chr(34) & " standalone=" & Chr(34) & "no" & Chr(34) & "?>" & _
"<DataMacros xmlns=" & Chr(34) & "http://schemas.microsoft.com/office/accessservices/2009/11/application" & Chr(34) & "><DataMacro Event=" & Chr(34) & "BeforeChange" & Chr(34) & "><Statements><ConditionalBlock><If>"
strXMLpath = Application.CurrentProject.Path & "\XML_File.xml"
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFile = fso.CreateTextFile(strXMLpath)
oFile.WriteLine strXML
oFile.Close
Set fso = Nothing
Set oFile = Nothing
strBE = CurrentDb.TableDefs("TableName").Connect
strBE = Replace(strBE, ";Database=", "")
Set accessApp = CreateObject("Access.Application")
accessApp.OpenCurrentDatabase strBE, True
accessApp.LoadFromText acTableDataMacro, "TableName", strXMLpath
Kill strXMLpath

Looping through folder with SQL query

strQuery = _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\Source1.xlsx' " & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;ExtendedProperties='HDR=YES;'] " & _
"UNION " & _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\Source2.xlsx' " & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=YES;'] " & _
"UNION " & _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\Source3.xlsx' " & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Extended Properties='HDR=YES;'] " & _
"ORDER BY A;"
Good morning,
I have one last nail to go on this coding I have and any help is much appreciated. I am gathering numerous files from a single folder and file names are different (although data order and data are same).
Question is:
Is it possible to get all files via the 'strQuery' without slowing down the code? How do I go on to do this? (eg: I think maybe loop but it might slow down? - see below)
Is it possible to get (say) 100 excel file data read at once? (although I do not know names of it?)
I can modify strQuery (via assigning it a text string) and input a loop to go through every file but I recon this would require me to create a connection for every single file rather than all at once?
Any help is appreciated!
Thanks in advance.
--
Full Code below (I didn't know where to put this in a visible manner)
Sub SqlUnionTest()
Dim strConnection As String
Dim strQuery As String
Dim objConnection As Object
Dim objRecordSet As Object, qText As String
strConnection = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"User ID=Admin;" & _
"Data Source='" & ThisWorkbook.FullName & "';" & _
"Mode=Read;" & _
"Extended Properties=""Excel 12.0 Macro;"";"
Dim sFile As String
sFile = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While sFile <> ""
strQuery = _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\" & sFile & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;ExtendedProperties='HDR=YES;'] " & _
"UNION "
sFile = Dir()
Loop
strQuery = Left(strQuery, Len(strQuery) - 7) 'to remove last UNION which is not necessary
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open strConnection
Set objRecordSet = objConnection.Execute(strQuery)
RecordSetToWorksheet Sheets(1), objRecordSet
objConnection.Close
End Sub
Sub RecordSetToWorksheet(objSheet As Worksheet, objRecordSet As Object)
Dim i As Long
With objSheet
.Cells.Delete
For i = 1 To objRecordSet.Fields.Count
.Cells(1, i).Value = objRecordSet.Fields(i - 1).Name
Next
.Cells(2, 1).CopyFromRecordset objRecordSet
.Cells.Columns.AutoFit
End With
End Sub
You can use the DIR() function to loop through all the .xlsx files in the folder without knowing the specific file names. If you need to weed out any files, you can place conditional testing inside the loop.
Code untested
Dim sFile As String, strQuery As String
sFile = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While sFile <> ""
strQuery = strQuery & _
"SELECT * FROM [Sheet1$A15:E999] " & _
"IN '" & ThisWorkbook.Path & "\" & sFile & _
"[Excel 12.0;Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;ExtendedProperties='HDR=YES;'] " & _
"UNION;"
sFile = Dir()
Loop
strQuery = Left(strQuery, Len(strQuery) - 7) 'to remove last UNION which is not necessary

VBScript BrowseForFile() Function - how to specify file types?

I found this function on GitHub and it's working great for what I need, but I can't figure out how to specify file type. It seems to default to "all".
Function BrowseForFile()
With CreateObject("WScript.Shell")
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim tempFolder : Set tempFolder = fso.GetSpecialFolder(2)
Dim tempName : tempName = fso.GetTempName() & ".hta"
Dim path : path = "HKCU\Volatile Environment\MsgResp"
With tempFolder.CreateTextFile(tempName)
.Write "<input type=file name=f><script>f.click()" & _
";(new ActiveXObject('WScript.Shell'))" & _
".RegWrite('HKCU\\Volatile Environment\\MsgResp', f.value)" & _
";close();<" & "/" & "script>"
.Close
End With
.Run tempFolder & "\" & tempName, 1, True
BrowseForFile = .RegRead(path)
.RegDelete path
fso.DeleteFile tempFolder & "\" & tempName
End With
End Function
'Example: msgbox BrowseForFile()
I tried modifying this line:
.Write "<input type=file name=f ><script>f.click()" & _
";(new ActiveXObject('WScript.Shell'))" & _
".RegWrite('HKCU\\Volatile Environment\\MsgResp', f.value)" & _
";close();<" & "/" & "script>"
To this:
.Write "<input type=file accept=" & chr(34) & "text/plain" & chr(34) & " name=f ><script>f.click()" & _
";(new ActiveXObject('WScript.Shell'))" & _
".RegWrite('HKCU\\Volatile Environment\\MsgResp', f.value)" & _
";close();<" & "/" & "script>"
But, still not working. Is there any way to use this function and customize the allowed file types? I want to allow only .csv, .txt, and .log
I used this function here : How to add filter to a file chooser in batch?
Function GetFileDlgEx(sIniDir,sFilter,sTitle)
Set oDlg = CreateObject("WScript.Shell").Exec("mshta.exe ""about:<object id=d classid=clsid:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object><script>moveTo(0,-9999);eval(new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(0).Read("&Len(sIniDir)+Len(sFilter)+Len(sTitle)+41&"));function window.onload(){var p=/[^\0]*/;new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).Write(p.exec(d.object.openfiledlg(iniDir,null,filter,title)));close();}</script><hta:application showintaskbar=no />""")
oDlg.StdIn.Write "var iniDir='" & sIniDir & "';var filter='" & sFilter & "';var title='" & sTitle & "';"
GetFileDlgEx = oDlg.StdOut.ReadAll
End Function
set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = fso.GetAbsolutePathName(".")
sIniDir = CurrentDirectory &"\Myfile.csv"
sFilter = "csv files (*.csv)|*.csv|txt files (*.txt)|*.txt|log files (*.log)|*.log|"
sTitle = "Put a title of your program here :) (-_°)"
MyFile = GetFileDlgEx(Replace(sIniDir,"\","\\"),sFilter,sTitle)
wscript.echo MyFile