wscript no longer uses run? and other gets a com reference issue,
the code is for editing current session for downloading the csv file.
every to this point works as it should.
If Dir(cf) = "" Then CreateObject("WScript.Shell").RUN "cmd.exe /s /c echo TEXT&echo.Enter your pin&echo.&echo. & " & f & " --aea --cookie-jar " & cf, vbNormalFocus, True
C = CreateObject("New:0D43FE01-F093-11CF-8940-00A0C9054228").OpenTextFile(cf).ReadAll
If InStr(C, vbTab) = 0 Or InStr(C, vbCrLf) = 0 Then JasperDruif = True: GoTo doitagain
Set t = CreateObject("New:47DFBE54-CF76-11D3-B38F-00105A1F473A")
t.SetVarDate Now
If Right(Split(C, vbTab & "session")(0), 10) / 1 < ((t.getVarDate(False) - 25569) * 86400) Then CreateObject("WScript.Shell").RUN "cmd.exe /s /c echo TEXT.&echo.Enter your pin&echo.&echo. & " & f & " --aea --cookie-jar " & cf, vbNormalFocus, True: C = CreateObject("New:0D43FE01-F093-11CF-8940-00A0C9054228").OpenTextFile(cf).ReadAll
Cookie = "session=" & Split(Split(C, "session" & vbTab)(1), vbCrLf)(0)
any idea how to make this work in vb.net, worked fine in vb6 and even on excel vba.
Related
I have an issue which i can't figure out.
Quest is to import csv file from a netdrive.
In a basic version files to import were selected automaticaly by code:
Function FilesAfterDate(Directory As String, FileSpec As String, AfterDate As Date) As String()
'Requires a reference to the Microsoft Scripting Runtime object lib
Dim oFS As New FileSystemObject, oFile As File
Dim listFiles() As String
Dim i As Long
i = 0
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
For Each oFile In oFS.GetFolder(Directory).files
If oFile.DateLastModified > AfterDate And oFile.Name Like FileSpec Then
ReDim Preserve listFiles(i)
listFiles(i) = oFile.Name
i = i + 1
End If
Next
FilesAfterDate = listFiles
End Function
And then it was imported by code (for each Importfiles(i) where ImportReport = fullpath of Importfiles(i))
DoCmd.TransferText acImportDelim, "ImpSpec_" & sObjSpec & "Csv", "tb" & sObjName & cloneTableNameDesc, ImportReport, False
This solution works really slow, so with the help of the users of this portal I've created a shell import:
fileDetails = Split(CreateObject("wscript.shell").exec("cmd /c pushd " & Chr(34) & source_path & Chr(34) & " & forfiles /S /D +" & s_data & " & popd").StdOut.ReadAll, Chr(10))
and if I use same import command where ImportReport = fullpath of fileDetails (i) i get an error number 31519.
I used debug.print to check all vartypes, path etc and they are all the same. However sollution with shell doesn't work... Any idea for the reason why?
SOLVED:
As I figure it out - splitting shell function to array somehow doesn't have right data/names for access.
It worked when instead of splitting the shell function i've just assigned it to string value
full_string_paths = CreateObject("wscript.shell").exec("cmd /c pushd " & Chr(34) & source_path & Chr(34) & " & forfiles /S /D +" & s_data & " & popd").StdOut.ReadAll
and then using Mid function and Instr I've created an array of correct filename's
After that everything worked perfectly.
I would like to use Excel VBA to run a CMD command.
The basic cmd command is:
"C:\Program Files\example program.exe" -w C:\Program files\outputfile.file "dir1" "dir2" "dir n+1"
The first part is the location of the program that will merge the files together.
The second part is the file location of the outputted merged files.
And the "dir1".... is the files that will be merged together.
I have code that lists the files to be merged but struggling to get the CMD code to get it so it does what I want as mentioned above. I have tried the following:
Sub RunCMD()
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim locationofprogram as string
'dir of program that will do the merge
Dim outputfolder as string
'dir of where the merged file will go
Dim listoffiles as string
'list of files to be merged
wsh.Run "cmd.exe /S /C locationofprogram & " " & "-w" & " " & outputfolder & " " & listoffiles, windowStyle, waitOnReturn
End Sub
Thanks for the help!
You can always create a .bat file, run the file, then delete it.
MyFile = "C:\Bat-File\Bat-File.bat"
fnum = FreeFile()
Open MyFile For Output As #fnum
Print #fnum, "C:\Program Files\example program.exe -w C:\Program files\outputfile.file dir1 dir2 dir n+1"
Close #fnum
Shell MyFile, vbNormalFocus
' wait 10 seconds to let bat file finnish
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 10
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
' delete bat-file
kill MyFile
I can't test that example program runs without the " around the dir´s so you have to see what happens.
But if it does not work you need to double enclose the " or use & CHR(34) &
If in doubt, send the text to the Immediate Window to see if it still matches the syntax using:
Debug.Print "cmd.exe /S /C " & locationofprogram & " " & "-w" & " " & outputfolder & " " & listoffiles
If that works, use:
wsh.Run "cmd.exe /S /C " & locationofprogram & " " & "-w" & " " & outputfolder & " " & listoffiles, windowStyle, waitOnReturn
The problem of this script is that it shows an unknown error Message while running the script.
I called the function by echo method in my ftp which is "filezilla".
every thing is working fine as it logs into the server check for the path, open channel for data writing. Still dont know where is the problem
Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath)
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Const OpenAsDefault = -2
Const FailIfNotExist = 0
Const ForReading = 1
Const ForWriting = 2
Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
Set oFTPScriptShell = CreateObject("WScript.Shell")
sRemotePath = Trim(sRemotePath)
sLocalFile = Trim(sLocalFile)
'----------Path Checks---------
'Here we willcheck the path, if it contains
'spaces then we need to add quotes to ensure
'it parses correctly.
If InStr(sRemotePath, " ") > 0 Then
If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
sRemotePath = """" & sRemotePath & """"
End If
End If
If InStr(sLocalFile, " ") > 0 Then
If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
sLocalFile = """" & sLocalFile & """"
End If
End If
'Check to ensure that a remote path was
'passed. If it's blank then pass a "\"
If Len(sRemotePath) = 0 Then
'Please note that no premptive checking of the
'remote path is done. If it does not exist for some
'reason. Unexpected results may occur.
sRemotePath = "\"
End If
'Check the local path and file to ensure
'that either the a file that exists was
'passed or a wildcard was passed.
If InStr(sLocalFile, "*") Then
If InStr(sLocalFile, " ") Then
FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _
"space." & vbCRLF
FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client."
Exit Function
End If
ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
'nothing to upload
FTPUpload = "Error: File Not Found."
Exit Function
End If
'--------END Path Checks---------
'build input file for ftp command
sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF
sFTPScript = sFTPScript & sPassword & vbCRLF
sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF
sFTPScript = sFTPScript & "binary" & vbCRLF
sFTPScript = sFTPScript & "prompt n" & vbCRLF
sFTPScript = sFTPScript & "put " & sLocalFile & vbCRLF
sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
'Write the input file for the ftp command
'to a temporary file.
Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
fFTPScript.WriteLine(sFTPScript)
fFTPScript.Close
Set fFTPScript = Nothing
oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
" > " & sFTPResults, 0, TRUE
Wscript.Sleep 1000
'Check results of transfer.
Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
FailIfNotExist, OpenAsDefault)
sResults = fFTPResults.ReadAll
fFTPResults.Close
oFTPScriptFSO.DeleteFile(sFTPTempFile)
oFTPScriptFSO.DeleteFile (sFTPResults)
If InStr(sResults, "226 Transfer complete.") > 0 Then
FTPUpload = True
ElseIf InStr(sResults, "File not found") > 0 Then
FTPUpload = "Error: File Not Found"
ElseIf InStr(sResults, "cannot log in.") > 0 Then
FTPUpload = "Error: Login Failed."
Else
FTPUpload = "Error: Unknown."
End If
Set oFTPScriptFSO = Nothing
Set oFTPScriptShell = Nothing
WScript.Echo "Process Completed (" & Now & ")"
End Function
I can use the following code to run a command from vba in the command prompt window
Private Sub CMDTest()
'command for cmd to execute
Dim command As String
command = "dir"
Call Shell("cmd.exe /S /K" & command)
End Sub
However it does not run with admin privileges. If command was something that required administrative privileges, how can I run it from vba with administrative privileges?
I have tried to used ShellExecute various ways and have had no luck. The code I used is below, I can open the command prompt window as an admin, however can not run the dir command.
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1
Public Sub test()
ShellExecute 0, "runas", "cmd.exe", "", vbNullString, SW_SHOWNORMAL
End Sub
Well, I may be late! say it is for the record :) Trying to answer the same question, the other topics I've read do not mention vba so I propose here a way to do it.
What it does: run wsshl from vba that opens a cmd prompt that test
current user rights, if not admin then it opens a powershell window
that opens a cmd prompt in admin mode that runs some cmd line
arguments... in one go (late binding, just msdos)
The trick: instead of running an external batch file or else, all
command are send in assembly line using dos & operator.
The problem: VBA wont wait for the last opened cmd window
(asynchrone) so I added... another cmd prompt to serve as 'waitonrun'
but also to check that no terrible thing happened. If there is no
need to wait or verify anything, they can be 'released'.
How it works: Enter your cmd arguments in mycmd variable, it can be
parametrized with vba variables, and run/compile. the UAC will prompt
to open a cmd window in admin mode and then follow the instructions.
Other possible use: use psargsList="echo." in psmeth 2, access to
last cmd prompt (admin mode) will be granted if you want to type
other commands instead of sending a bunch of arguments. In that case
the 'waitonrun' prompt allow to pause vba until you finished.
Here an example to take back ownership of a file using icacls.
Sub acmd()
'--------
'settings
'--------
Dim output As String: output = Environ("userprofile") & "\Desktop\test.txt" ' a file
Dim mycmd As String: mycmd = "icacls " & output & " /grant %username%:F " 'an msdos cmd to run as admin
'---------
'2 methods
'---------
'exact same versions but different syntax, the first is shorter, the second uses -ArgumentList argument of powershell that can be usefull in other cases
'note: first run of powershell may take some time
Dim psmeth As Long: psmeth = 1 '2
Dim psargsList As String, psargs As String
'------
'layout
'------
'trying to lighten a bit the expression and the cmd prompt
'msg could also be other cmd arguments
Dim msg1 As String, msg2 As String, msg3 As String
msg1 = "echo.& echo.""- listing files with ownership"" & echo."
msg2 = "echo.& echo.""- applying cmd"" & echo.& echo. "
msg3 = "echo.& echo.""Done! now press [enter]"" & echo."
With CreateObject("wScript.Shell")
If psmeth = 1 Then
'add an msdos '&' between msdos args and cut the vba string with a vba '&' where you want to insert vba variables
'from the last cmd point of view it will be the same cmd line, a succession of cmd arg1 & arg2 & arg3, the 'encapsulation' between \"""" is a bit more tricky
'there are some warnings you can see when using -noexit after powershell cmd but it doesn't seems to hurt
psargs = msg1 & " & dir " & output & " /q & " & msg2 & " & " & mycmd & " & " & msg3 & " & pause"
.Run "cmd /c net session >nul 2>&1 & if ERRORLEVEL 1 ( Powershell -Command ""& { Start-Process cmd.exe \""""/c " & psargs & "\"""" -verb RunAs -wait }"" )", 1, True ' 3rd win only? ok too; add -noexit after Powershell to see warnings
ElseIf psmeth = 2 Then
'based on same principle, it works also with powershell's -ArgumenList 'arg1','& arg2','& arg3',.. syntax, there is a little less escaping but it needs to open a '4th' cmd window with /k (and VBA wont wait for it!) so that it doesn't close and runs cmd line args in assembly line
'the cuts '...', are arbitrary, then inside them cut the vba string to insert vba variables
psargsList = "-ArgumentList 'cmd /k ','" & msg1 & " & echo. &','dir " & output & " /q ',' & echo. & " & msg2 & "',' & " & mycmd & " ','& " & msg3 & " & pause ','& exit'"
.Run "cmd /c net session >nul 2>&1 & if ERRORLEVEL 1 ( Powershell -Command ""& { Start-Process cmd.exe " & psargsList & " -verb RunAs -wait }"" )", 1, True
End If
If psmeth = 1 Or psmeth = 2 Then
'we need some 'waitonrun', here a simple confirmation window
.Run "cmd /c tasklist |find ""cmd.exe"" >nul && (set /p""= Holding on VBA till you close admin windows. Press [enter] when ready"" & taskkill /f /im ""cmd.exe"") || echo. ""dummy"">nul", 1, True
End If
End With
'------------------
Debug.Print "-end-"
'------------------
End Sub
What you are doing should work. Here is a helper I have used.
Private Sub RunAsAdmin(ByVal command As String, ByVal parameters As String)
ShellExecute 0, "runas", command, parameters, vbNullString, SW_SHOWNORMAL
End Sub
This vbsscript, compatable with VBA, runs a verb from right click menu on a file. Programs have RunAs to elevate to admins on their menus.
HelpMsg = vbcrlf & " ShVerb" & vbcrlf & vbcrlf & " David Candy 2014" & vbcrlf & vbcrlf & " Lists or runs an explorer verb (right click menu) on a file or folder" & vbcrlf & vbcrlf & " ShVerb <filename> [verb]" & vbcrlf & vbcrlf & " Used without a verb it lists the verbs available for the file or folder" & vbcrlf & vbcrlf
HelpMsg = HelpMsg & " The program lists most verbs but only ones above the first separator" & vbcrlf & " of the menu work when used this way" & vbcrlf & vbcrlf
HelpMsg = HelpMsg & " The Properties verb can be used. However the program has to keep running" & vbcrlf & " to hold the properties dialog open. It keeps running by displaying" & vbcrlf & " a message box."
Set objShell = CreateObject("Shell.Application")
Set Ag = WScript.Arguments
set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
If Ag.count = 0 then
wscript.echo " ShVerb - No file specified"
wscript.echo HelpMsg
wscript.quit
Else If Ag.count = 1 then
If LCase(Replace(Ag(0),"-", "/")) = "/h" or Replace(Ag(0),"-", "/") = "/?" then
wscript.echo HelpMsg
wscript.quit
End If
ElseIf Ag.count > 2 then
wscript.echo vbcrlf & " ShVerb - To many parameters" & vbcrlf & " Use quotes around filenames and verbs containing spaces" & vbcrlf
wscript.echo HelpMsg
wscript.quit
End If
If fso.DriveExists(Ag(0)) = True then
Set objFolder = objShell.Namespace(fso.GetFileName(Ag(0)))
' Set objFolderItem = objFolder.ParseName(fso.GetFileName(Ag(0)))
Set objFolderItem = objFolder.self
msgbox ag(0)
ElseIf fso.FolderExists(Ag(0)) = True then
Set objFolder = objShell.Namespace(fso.GetParentFolderName(Ag(0)))
Set objFolderItem = objFolder.ParseName(fso.GetFileName(Ag(0)))
ElseIf fso.fileExists(Ag(0)) = True then
Set objFolder = objShell.Namespace(fso.GetParentFolderName(Ag(0)))
Set objFolderItem = objFolder.ParseName(fso.GetFileName(Ag(0)))
Else
wscript.echo " ShVerb - " & Ag(0) & " not found"
wscript.echo HelpMsg
wscript.quit
End If
Set objVerbs = objFolderItem.Verbs
'If only one argument list verbs for that item
If Ag.count = 1 then
For Each cmd in objFolderItem.Verbs
If len(cmd) <> 0 then CmdList = CmdList & vbcrlf & replace(cmd.name, "&", "")
Next
wscript.echo mid(CmdList, 2)
'If two arguments do verbs for that item
ElseIf Ag.count = 2 then
For Each cmd in objFolderItem.Verbs
If lcase(replace(cmd, "&", "")) = LCase(Ag(1)) then
wscript.echo(Cmd.doit)
Exit For
End If
Next
'Properties is special cased. Script has to stay running for Properties dialog to show.
If Lcase(Ag(1)) = "properties" then
WSHShell.AppActivate(ObjFolderItem.Name & " Properties")
msgbox "This message box has to stay open to keep the " & ObjFolderItem.Name & " Properties dialog open."
End If
End If
End If
I'm trying to move my entire User folder in Vista to a non-system partition. To do so with a minimum hassle I'm following the directions provided at Ben's Blog, specifically the vbs script he provides. However executing the script throws up an error which I can't resolve myself. Here's the vbs code followed by the text file it calls on, and finally my error message. Can someone help me correct the problem? (I really don't know much about VBS, so please write as simple as possible.)
VBS Code:
'# Perform dir /a c:\users > c:\dir.txt
'# place this script file in c:\ too
'# double click to run it
'# run resulting script.bat from recovery mode
repprefix = " Directory of..." ' Modify to your language
sourcedrive = "C:\"
targetdrive = "D:\"
altsourcedrive = "C:\" 'leave same as target drive unless otherwise indicated
alttargetdrive = "E:\" 'leave same as target drive unless otherwise indicated
inname = "dir.txt"
outname = "script.bat"
userroot = "Users"
set fso = CreateObject("Scripting.FileSystemObject")
' construct batch commands for saving rights, then link, the recreating rights
Function GetCommand(curroot, line, typ, keyword)
' first need to get source and target
pos = Instr(line, keyword) + Len(keyword)
tuple = Trim(Mid(line, pos))
arr = Split(tuple, "[")
oldtarget = Replace(arr(1), "]", "")
oldlink = curroot & "\" & Trim(arr(0))
' need to determine if we are pointing back to old disk
newlink = replace(oldlink, sourcedrive, targetdrive)
if(Instr(oldtarget, sourcedrive & userroot)) then
newtarget = Replace(oldtarget, sourcedrive, targetdrive)
else
newtarget = oldtarget ' still pointing to original target
end if
' comment
out = "echo " & newlink & " --- " & newtarget & vbCrLf
' save permissions
out = out & "icacls """ & replace(oldlink, sourcedrive, altsourcedrive) & """ /L /save " & altsourcedrive & "permissions.txt" & vbCrLf
' create link
newlink = replace(newlink, targetdrive, alttargetdrive)
if typ = "junction" then
out = out & "mklink /j """ & newlink & """ """ & newtarget & """" & vbCrLf
else ' typ = "symlink"
out = out & "mklink /d """ & newlink & """ """ & newtarget & """" & vbCrLf
end if
'set hidden attribute
out = out & "attrib +h """ & newlink & """ /L" & vbCrLf
' apply permissions
shortlink = Left(newlink, InstrRev(newlink, "\") - 1) 'icacls works strangely - non-orthogonal for restore
out = out & "icacls """ & shortlink & """ /L /restore " & altsourcedrive & "permissions.txt" & vbCrLf
GetCommand = out & vbCrLf
End Function
Sub WriteToFile(file, text)
ForWriting = 2
Create = true
set outfile = fso.OpenTextFile(file, ForWriting, Create)
Call outfile.Write(text)
Call outfile.Close()
End Sub
outtext = "ROBOCOPY " & altsourcedrive & userroot & " " & alttargetdrive & userroot & " /E /COPYALL /XJ" & vbCrLf & vbCrLf
set intext = fso.OpenTextFile(inname)
while not intext.AtEndOfStream
line = intext.ReadLine()
if Instr(line, repprefix) then
curroot = Replace(line, repprefix, "")
elseif Instr(line, juncname) then
outtext = outtext & GetCommand(curroot, line, "junction", juncname)
elseif Instr(line, linkname) then
outtext = outtext & GetCommand(curroot, line, "symlink", linkname)
end if
Wend
outtext = outtext & "icacls " & altsourcedrive & userroot & " /L /save " & altsourcedrive & "permissions.txt" & vbCrLf
outtext = outtext & "ren " & altsourcedrive & userroot & " _" & userroot & vbCrLf
outtext = outtext & "mklink /j " & altsourcedrive & userroot & " " & targetdrive & userroot & vbCrLf
outtext = outtext & "icacls " & altsourcedrive & " /L /restore " & altsourcedrive & "permissions.txt"
Call intext.Close()
Call WriteToFile(outname, outtext)
MsgBox("Done writing to " & outname)
dir.txt:
Volume in drive C is ACER
Volume Serial Number is 08D7-C0CC
Directory of c:\users
07/16/2009 12:29 PM <DIR
07/16/2009 12:29 PM <DIR> ..
11/02/2006 09:02 AM <SYMLINKD> All Users [C:\ProgramData]
11/02/2006 09:02 AM <DIR> Default
11/02/2006 09:02 AM <JUNCTION> Default User [C:\Users\Default]
08/21/2008 08:37 AM 174 desktop.ini
11/02/2006 08:50 AM <DIR> Public
07/19/2009 08:54 PM <DIR> Steve
1 File(s) 174 bytes
7 Dir(s) 5,679,947,776 bytes free
Error Message:
Windows Script Host
Script: C:\userlocationchange.vbs
Line: 25
Char: 2
Error: Subscript out of range: '[number: 1]'
Code: 800A0009
Source: Microsoft VBScript runtime error
The problem is at these lines:
arr = Split(tuple, "[")
oldtarget = Replace(arr(1), "]", "")
I assume that arr(1) is giving the error because arr has only one entry - and since arrays are zero-based in VBS, that entry should be accessed as arr(0).
Hmmm... if there's only one entry, then presumably no "[" was found. The code probably needs to check for that (by testing whether UBound(arr) > 1).
What that means in a wider context - i.e. why there's no "[" I can't say.
EDIT: OK, I took a look at the blog you referred to, and the exact same problem was reported. The blog author replied:
A couple of pointers: look in the txt
file output by the dir command. On my
system, the targets of the symlinks
are shown in square brackets [].
Apparently in your case there aren't
any - in any case that is a hypothesis
that would explain why the script
can't parse out the link targets.
...which pretty much confirms my theory. I suggest you do as he suggests and take a look at the txt file to see if some other character is used.
Note that this isn't really a problem with the script per se - it's just that the script expects some input that it's not getting.
#Gary, I'm the same one who reported the problem on that blog.
I posted the txt file here under the VBS code. My txt file also has the symlink-junction targets within square brackets. Is there anything else I'm missing?