Unable to run vbscript file due to access limit - html

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.

Related

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

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.

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

Fix link on-the-fly as an Error handle for error 3044 or more

I have a massive set of linked databases that have the potential to move. Luckily they are all in ONE working directory of nested folders.
I have effectively created a module that has the path of this working folder defined.
As strWorkingFolder
Now the VBA of the main control center remains intact for multiple calls running and executing queries (append, delete, insert) etc. EXCEPT each of the databases that are still linked to the old folder.
I figured that whenever the error 3044 (Not sure of the exact verbiage "The path to this table does not exist), I could just relink to the correct path - because it is known: It would be strWorkingFolder (concatenated to whatever nested folder the database is in)
I thought I could get away with just linked tables, but apparently, I will need to re-link all kinds of files: csv, Excel, as well as ACCDB.
How can I get it to work?
This is currently what I have setup
Sub RemoveLinks()
Dim tdf As TableDef
For Each tdf In CurrentDb.TableDefs
If Left(tdf.Name, 4) <> "MSys" And (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
CurrentDb.TableDefs.Delete tdf.Name
End If
Next tdf
Set tdf = Nothing
End Sub
Sub LinkDatabase(StrDBPath As String)
Dim dbs As Database
Dim tdf As TableDef
Set dbs = OpenDatabase(StrDBPath)
For Each tdf In dbs.TableDefs
If Left(tdf.Name, 4) <> "MSys" Then
DoCmd.TransferDatabase acLink, "Microsoft Access", Trim(StrDBPath), acTable, tdf.Name, tdf.Name
SysCmd acSysCmdSetStatus, "Processing table [" & tdf.Name & "]..."
End If
Next tdf
SysCmd acSysCmdClearStatus
Set dbs = Nothing
Set tdf = Nothing
End Sub
Sub RefreshLinks(StrDBPath As String)
Dim tdf As TableDef
For Each tdf In CurrentDb.TableDefs
If (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
tdf.Connect = "; Database = " & StrDBPath
SysCmd acSysCmdSetStatus, "Processing table [" & tdf.Name & "]..."
tdf.RefreshLink
End If
Next tdf
Set tdf = Nothing
SysCmd acSysCmdClearStatus
End Sub
And finally, in the error_handler, I will trap 3044 and call
Public Sub Relink(strEnginePath)
Dim dbs As Database
Set dbs = CurrentDb
RemoveLinks
LinkDatabase (strEnginePath)
RefreshLinks (strEnginePath)
End Sub
Is there a better way to go about this?
I have altered your code so it will handle text and Excel in addition to Access tables. If you have other types attached, you need to modify the code.
NOTE: With this code, you should NOT delete the links because that will remove all of the attributes you need!
Also, if you have any parameters following the path/file names in the connect strings, you need to add code to retain that information. I hope you have some standards in place that would allow some logical actions to be taken.
Sub RefreshLinks(StrDBPath As String)
Dim iLen As Integer
Dim iStart As Integer
Dim iEnd As Integer
Dim iPos As Integer
Dim strOldConn As String
Dim strNewConn As String
Dim strFile As String
Dim tdf As TableDef
On Error GoTo Error_Trap
For Each tdf In CurrentDb.TableDefs
If (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
Debug.Print "Table Name: " & tdf.Name
strOldConn = tdf.Connect ' Save the connect string
iLen = Len(strOldConn)
iStart = InStr(1, strOldConn, "DATABASE=") ' Find start of path
iEnd = InStr(iStart + 1, strOldConn, ";") ' Is there more after path?
Debug.Print tdf.Name & ": " & tdf.Connect
If LCase(left(strOldConn, 4)) = "text" Then ' Text file attached
strNewConn = left(strOldConn, iStart + 8) & StrDBPath
ElseIf LCase(left(strOldConn, 5)) = "excel" Then ' Excel file attached
strFile = ""
For iPos = iLen To 1 Step -1 ' Get the file name from the path
If Mid(strOldConn, iPos, 1) = "\" Then Exit For
strFile = Mid(strOldConn, iPos, 1) & strFile
Next
If iPos = 0 Then
MsgBox "Did not find path delimiter '\'" & vbCrLf & vbCrLf & "for TDF '" & tdf.Name & "'", vbOKOnly + vbCritical, "Path Delimiter Unknown"
End If
strNewConn = left(strOldConn, iStart + 8) & StrDBPath & "\" & strFile
Else
' Assume it is Access table. If other types, add code to handle.
strFile = ""
For iPos = iLen To 1 Step -1 ' Get the file name from the path
If Mid(strOldConn, iPos, 1) = "\" Then Exit For
strFile = Mid(strOldConn, iPos, 1) & strFile
Next
If iPos = 0 Then
MsgBox "Did not find path delimiter '\' in connect string '" & strOldConn & "'", vbOKOnly + vbCritical, "Wrong delimiter?"
End If
strNewConn = left(strOldConn, iStart + 8) & StrDBPath & "\" & strFile
End If
Debug.Print " (new): " & strNewConn
tdf.Connect = strNewConn
SysCmd acSysCmdSetStatus, "Processing table [" & tdf.Name & "]..."
tdf.RefreshLink
Else
' Ignore this table since it is not linked.
End If
Next tdf
Set tdf = Nothing
SysCmd acSysCmdClearStatus
Exit Sub
Error_Trap:
MsgBox "Error: " & Err.Number & vbTab & Err.Description & vbCrLf & vbCrLf & _
"While processing table: " & tdf.Name & vbCrLf & _
"Old: " & strOldConn & vbCrLf & _
"New: " & strNewConn, vbOKOnly, "Relink Error"
Exit Sub
End Sub

Access VBA passing parameters vbs file

i am creating a .vbs file that should open access, and inside access a form call "Issue Details", but passing a parameter, meaning that if i have 10 issues in my "Issues" table a vbs file is created for each one and when clicked should open the right record(would be one ID for each record in the table). It is so far opening access and it is opening the form(Issue Details) but it is blank. What am i missing? Help, getting crazy here ... Check code below. The weird thing here is that if i double click it again it will refresh and open the right record without opening anymore windows.. How can i fix that? I dont want to do it twice :)
Public Sub sendMRBmail(mrbid)
DoCmd.OpenForm "Issue Details", , , "[ID] = " & mrbid
End Sub
Private Sub Create_Click()
On Error GoTo Err_Command48_Click
Dim snid As Integer
snid = Me.ID
Dim filename As String
filename = "S:\Quality Control\vbs\QC" & snid & ".vbs"
Dim proc As String
proc = Chr(34) & "sendMRBmail" & Chr(34)
Dim strList As String
strList = "On Error Resume Next" & vbNewLine
strList = strList & "dim accessApp" & vbNewLine
strList = strList & "set accessApp = createObject(" & Chr(34) & "Access.Application" & Chr (34)")" & vbNewLine
strList = strList & "accessApp.OpenCurrentDataBase(" & Chr(34) & "S:\Quality Control\Quality DB\Quality Database.accdb" & Chr(34) & ")" & vbNewLine
strList = strList & "accessApp.Run " & proc & "," & Chr(34) & snid & Chr(34) & vbNewLine
strList = strList & "set accessApp = nothing" & vbNewLine
Open filename For Output As #1
Print #1, strList
Close #1
Err_Command48_Click:
If Err.Number <> 0 Then
MsgBox "Email Error #: " & Err.Number & ", " & "Description: " & Err.Description
Exit Sub
End If
End Sub
This is what is inside a created vbs file
On Error Resume Next
dim accessApp
set accessApp = GetObject("S:\Quality Control\Quality DB\Quality Database.accdb")
accessApp.Run"sendMRBmail","231"
set accessApp = nothing
Thanks to all that made inputs, i already found the answer. I added acFormEdit at the end of my DoCmd and it worked, check below:
DoCmd.OpenForm "Issue Details", , , "[ID] = " & mrbid, acFormEdit