I am sharing an Excel workbook with multiple users who are executing a macro that executes the following WinSCP batch script:
"C:\Program Files (x86)\WinSCP\WinSCP.com" ^
/command ^
"open ftp://user:pass#ftp.website.org/" ^
"cd /incoming/data" ^
"put ""%~dp0file.txt""" ^
"exit"
set WINSCP_RESULT=%ERRORLEVEL%
if %WINSCP_RESULT% equ 0 (
echo Success
) else (
echo Error
)
exit /b %WINSCP_RESULT%
The script is executed from VBA as follows:
Call Shell("C:\Users\" & Environ("username") & "\Sharepoint - Library Folder\FTP\ftpupload.bat")
When executed, the command window appears for 1-2 seconds and goes away. Is there a way to leave it up with the Success/Error result or even better would be to pass it back to VBA so I can display the result in an Ok-Window?
Note: I'd like to avoid having to register the WinSCP COM in VBA as this workbook is being used by multiple people and I need to keep it simple with as little prerequisites as possible.
Your batch file already returns exit code indicating an error/success.
So all you need is to capture the code and act accordingly.
For that, see Is it possible to return error code to VBA from batch file?
Set oSHELL = VBA.CreateObject("WScript.Shell")
Dim exitCode As Integer
exitCode = oSHELL.Run("""C:\Users\" & Environ("username") & "\Sharepoint - Library Folder\FTP\ftpupload.bat""", 0, True)
If exitCode <> 0 Then
MsgBox "Failed", vbOKOnly, "Failure"
Else
MsgBox "Succeeded", vbOKOnly, "Success"
End If
Related
SECOND EDIT/UPDATE: tried the path change recommendations, did not see any changes to the command string, still does not work. I re-wrote the code to use a fixed text file instead of a random temp file so I could monitor the contents of the file during execution. Able to conclusively show it is the
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 0, True
code line that doesn't behave as expected. Still works with the w32tm command line, but not with the ntpq command line. With ntpq command, no changes made to the file, no error flags. I also tried out (again) the exec version of this problem where the window is supposed to flash a bit before it gets hidden programmatically. I get the expected reslut using exactly the same command string, cut and pasted into the other code. So the same command line works with manual entry into CMD, into PowerShell, and in the .exec code version, not the .run code version.
End of second edit. -------------------
EDIT: more debugging... ntpq -p works if I do .exec instead of .run, but then of course can't hid the cmd window. Extra test code at the end.
This Works: If I run these two commands in manually opened cmd window, or PowerShell window, both give the expected results.
w32tm /stripchart /computer:time.nist.gov /dataonly /samples:3 /rdtsc /period:1
ntpq -p
The second, ntpq -p, is bundled with NTP windows software from the home of the Network Time Protocol project that gives similar information to windows' w32tm when NTP is set up to look at the same time service computer as in the w32tm command.
This Doesn't work:
When I try to use these two command string when running CMD functions hidden using the classic "write to file" method shown in SO here and other places, the w32tm version gives the same results as the manual version, but the ntpq version just returns "error".
I read every single one of the recommended links for this question as well as searching OS and Google, and have not found an answer.
I am stuck on next step to troubleshoot the problem...only thing I could think of was to run the commands manually to confirm they work there. I can't imagine it being a administrator privileges issue since I can run them both in CMD line or PowerShell windows opened at normal rights level.
What should I look at next?
Here is the test code.
Option Explicit
Sub TestShellRun()
Dim sCmd As String, sReturnNTP As String
sCmd = "w32tm /stripchart /computer:time.nist.gov /dataonly /samples:3 /rdtsc /period:1 " ' /packetinfo"
sCmd = "%ComSpec% /C %SystemRoot%\system32\" & sCmd
sReturnNTP = fShellRun(sCmd) 'good return value, same as manual cmd line
Debug.Print sReturnNTP
sCmd = "ntpq -p"
sCmd = "%ComSpec% /C %SystemRoot%\system32\" & sCmd
sReturnNTP = fShellRun(sCmd) 'ERROR return value, even though manual cmd line has good values
Debug.Print sReturnNTP
End Sub
Public Function fShellRun(sCommandStringToExecute) As String
' This function will accept a string as a DOS command to execute.
' It will then execute the command in a shell, and capture the output into a file.
' That file is then read in and its contents are returned as the value the function returns.
' "myIP" is a user-selected global variable
Dim oShellObject, oFileSystemObject, sShellRndTmpFile
Dim oShellOutputFileToRead
Dim iErr As Long
Set oShellObject = CreateObject("Wscript.Shell")
Set oFileSystemObject = CreateObject("Scripting.FileSystemObject")
sShellRndTmpFile = oShellObject.ExpandEnvironmentStrings("%temp%") & oFileSystemObject.GetTempName
On Error Resume Next
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 0, True
iErr = Err.Number
On Error GoTo 0
If iErr <> 0 Then
fShellRun = "error"
Exit Function
End If
On Error GoTo err_skip
fShellRun = oFileSystemObject.OpenTextFile(sShellRndTmpFile, 1).ReadAll
oFileSystemObject.DeleteFile sShellRndTmpFile, True
Exit Function
err_skip:
fShellRun = "error"
oFileSystemObject.DeleteFile sShellRndTmpFile, True
End Function
sCommand = "ntpq.exe -p"
Set WshShell = CreateObject("WScript.Shell")
Set WshShellExec = WshShell.Exec(sCommand)
strOutput = WshShellExec.StdOut.ReadAll
Debug.Print strOutput
Your fShellRun function didn't work due to error in temporary file path. Here is fixed version.
Function fShellRun(sCommandStringToExecute) As String
...
'invalid file path without path separator between directory path and filename!
sShellRndTmpFile = oShellObject.ExpandEnvironmentStrings("%temp%") & _
oFileSystemObject.GetTempName
'valid path with path separator between directory path and filename
sShellRndTmpFile = oFileSystemObject.BuildPath( _
Environ("temp"), oFileSystemObject.GetTempName)
...
End Function
I am having some problems running a shell command and checking the output of the data. I wish to check using vba if the current remote user of the DB is Active. In
command prompt =
for /f "tokens=1-8" %a in ('quser') do #if "%d"== "Active" echo %COMPUTERNAME% %a %d
returns the users logged on and their state I wish to check that none of them are disconnected ("Disc"). I used this function to check the shell and return the pipe value as a string in a message box
Public Function ShellRun(sCmd As String) As String
'Run a shell command, returning the output as a string'
Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")
'run command'
Dim oExec As Object
Dim oOutput As Object
Set oExec = oShell.Exec(sCmd)
Set oOutput = oExec.StdOut
Debug.Print sCmd
'handle the results as they are written to and read from the StdOut object'
Dim s As String
Dim sLine As String
While Not oOutput.AtEndOfStream
sLine = oOutput.ReadLine
If sLine <> "" Then s = s & sLine & vbCrLf
Wend
ShellRun = s
'example MsgBox ShellRun("cmd.exe /c" & "dir c:\")
End Function
Call Command used on click event
Dim CMDLineCommand As String
CMDLineCommand = "for /f ""tokens=1-8"" %a in ('quser') do #if ""%d""== ""Active"" echo %COMPUTERNAME% %a %d"
'(CMDLineCommand = "dir c:\")<------ THIS WORKS FINE
MsgBox ShellRun("cmd.exe /c " & CMDLineCommand)
This works fine for loads of command line commands I have tested it with but not query and therefore query user. The query user command works fine from command line but does not return anything when issued through a VBA Shell commands.
Any thoughts would be appreciated.
because shell does not know the path of the query.exe(quesr) it does not continue where as command prompt can use system variables to find exe's. solution find the query.exe and copy it to a working directory then run the shell command. mine was located in a hashed folder within C:\Windows\WinSxS be careful as here are 64bit versions and 32 bit.
Problem Summary: Creating a text file for FTP commands is not finishing by the time the command file needs to be called. It won't trap with a "if file exists". How to make sure the file is created before continuing with the code?
Details: I'm working on an portion of code in my Excel workbook to FTP some files. To do that, I'm creating a FTPcmd.txt file via code containing the FTP commands, closing the file and then shelling the FTP command in the CMD window. It looks like the command file is taking too long to complete the write and, therefore, I'm getting an "Permission Refused" error. The FTP log says "Error opening script file C:\temp\FTPcmd.txt." I am error checking to see if the file exists, but I think the file shows up as existing after the open statement, not the close. I'm not hitting the else statement in the DIR <>"" The IsFileOpen function was found on "http://www.vbaexpress.com/kb/getarticle.php?kb_id=468 VBA Express : Excel - Check If a File Is Already Open"
I don't believe it's a problem ShellWait problem. I need the file to write before I call the Shell.
If I step through it manually, it works, after I see the file appear in the directory.
I'm also piping the FTP output to a file and reading it back in for success/failure messaging in a similar manner and I'm getting the same problem with that.
Anyone have any ideas? Thanks in advance!
Open temppath & "FTPcmd.txt" For Output As #2
Print #2, "user " & FSOUserName
Print #2, FSOpw
Print #2, "lcd " & temppath
Print #2, "cd public_html"
Print #2, "binary"
Print #2, "mput " & Chr(34) & "index.htm" & Chr(34)
Print #2, "cd .."
Print #2, "cd public_ftp"
Print #2, "mput " & Chr(34) & myfilename & Chr(34)
Print #2, "bye"
Close #2
Start = Timer
FTPlooper:
If Timer - Start > 30 Then saveme = 1: Text = Text & " FTP Failure": GoTo failpoint
If Dir(temppath & "FTPcmd.txt") <> "" And IsFileOpen(temppath & "FTPcmd.txt") = False Then
Shell "cmd /c ftp -n -i -g -s:" & temppath & "FtpCmd.txt " & FSOHostURL & ">" & temppath & "ftpout.txt 2>&1"
Else
GoTo FTPlooper
End If
Here's the function I'm using to see if the file is open.
Code:
Function IsFileOpen(FileName As String)'http://www.vbaexpress.com/kb/getarticle.php?kb_id=468
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
Output of FTPout.txt:
Error opening script file C:\Users\Theresa\Downloads\FTPcmd.txt.
Transfers files to and from a computer running an FTP server service
(sometimes called a daemon). Ftp can be used interactively.
FTP [-v] [-d] [-i] [-n] [-g] [-s:filename] [-a] [-A] [-x:sendbuffer]
[-r:recvbuffer] [-b:asyncbuffers] [-w:windowsize] [host]
-v Suppresses display of remote server responses. -n
Suppresses auto-login upon initial connection. -i Turns
off interactive prompting during multiple file
transfers. -d Enables debugging. -g Disables filename globbing (see GLOB command). -s:filename
Specifies a text file containing FTP commands; the
commands will automatically run after FTP starts. -a Use any local interface when binding data connection. -A login as anonymous. -x:send sockbuf Overrides the default SO_SNDBUF size of 8192. -r:recv sockbuf Overrides the
default SO_RCVBUF size of 8192. -b:async count Overrides the
default async count of 3 -w:windowsize Overrides the default
transfer buffer size of 65535. host Specifies the host
name or IP address of the remote
host to connect to.
Notes:
- mget and mput commands take y/n/q for yes/no/quit.
- Use Control-C to abort commands.
So I have created a visual basic script in outlook that creates a random signature by pulling from Git.
The script works correctly but whenever I restart my machine the script doesn't run at all.
I fixed the issue by going to
"File"->"Options"->"Trust Center"->"Trust Center Settings..."->"Macro Settings"->"Enable all macros"
This let the VBA code work whenever I opened and closed Outlook but is there a better way to have the code work whenever I reopen Outlook or restart my machine.
I have tried to use
Private Sub Application_Startup()
MsgBox "Hi"
End Sub
While that code did work when I first put it in, whenever I restarted outlook it said it couldn't run because "Macros were disabled"
Here is my code for the random signature, anyway to have this work whenever I restart outlook or my machine? Or is the macro setting I edited the correct way to go?
Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' Validate that the item sent is an email.
If Item.Class <> olMail Then Exit Sub
'These first variables is to find the file the .bat file created within the AppData folder
'Set enviro to %APPDATA%
Dim enviro As String
enviro = CStr(Environ("APPDATA"))
'Create a new variable that sets the file path for the RepoDir.txt
RepoPath = enviro & "\RepoDir.txt"
'Create a new variable to grab the line of text in RepoDir.txt
Dim RepoFilePath As String
Dim strFirstLine As String
'The new variable calls the RepoPath Variable, opens it and reads the first line of the file and copies it into a variable
RepoFilePath = RepoPath
Open RepoFilePath For Input As #1
Line Input #1, strFirstLine
Close #1
'The script runs a Shell command that opens the command line, cds to the Repo path within the str variable, does a git pull, and outputs the error level to a file in the temp directory
Shell ("cmd /c cd " & strFirstLine & " & git pull RandomSig & echo %ERRORLEVEL% > %TEMP%\gitPull.txt 2>&1")
'These second set of variables is to find the file the Shell command created within the TEMP folder
'Set enviro to %TEMP%
Dim Gitenviro As String
Gitenviro = CStr(Environ("TEMP"))
'Create a new variable that sets the file path for the RepoDir.txt
PullResult = Gitenviro & "\gitPull.txt"
'Create a new variable to grab the line of text in RepoDir.txt
Dim GitFilePath As String
Dim GitFirstLine As String
'The new variable calls the PullResult Variable, opens it and reads the first line of the file and copies it into a variable
GitFilePath = PullResult
Open GitFilePath For Input As #2
Line Input #2, GitFirstLine
Close #2
'MsgBox (GitFirstLine)
'The variable is checked to see if it does not equal 0, and if it doesn't the message is cancelled
If GitFirstLine <> 0 Then
MsgBox "There was an error when attempting to do the Git Pull, cancelling message"
Cancel = True
End If
Const SearchString = "%Random_Line%"
Dim QuotesFile As String
QuotesFile = strFirstLine & "quotes.txt"
If InStr(Item.Body, SearchString) Then
If FileOrDirExists(QuotesFile) = False Then
MsgBox ("Quotes file wasn't found! Canceling message")
Cancel = True
Else
Dim lines() As String
Dim numLines As Integer
numLines = 0
' Open the file for reading
Open QuotesFile For Input As #1
' Go over each line in the file and save it in the array + count it
Do Until EOF(1)
ReDim Preserve lines(numLines + 1)
Line Input #1, lines(numLines)
numLines = numLines + 1
Loop
Close #1
' Get the random line number
Dim randLine As Integer
randLine = Int(numLines * Rnd()) + 1
' Insert the random quote
Item.HTMLBody = Replace(Item.HTMLBody, SearchString, lines(randLine))
Item.HTMLBody = Replace(Item.HTMLBody, "%Random_Num%", randLine)
End If
End If
End Sub
Function FileOrDirExists(PathName As String)
Dim iTemp As Integer
On Error Resume Next
iTemp = GetAttr(PathName)
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
On Error GoTo 0
End Function
It’s highly recommended to leave your macro security setting to only allow self-sign certificate Macros,
Do not use the Low option or run all
Create a self-signing certificate
Go to Start > All Programs > Microsoft Office > Microsoft Office Tools, and then click Digital Certificate for VBA Projects.
In the Your certificate's name box, type in name for the certificate.
Click OK. then SelfCert Success message will appears, click OK.
Go to Developer tab > click Visual Basic. or ALT+F11
In Visual Basic Editor, go to Tools > Digital Signature.
Digital Signature dialog appears and click on Choose and you’ll get a screen to select a certificate. Now you can choose the certificate you just created.
Edit
locating SelfCert.exe
Go to Start menu and typing VBA should bring up the SelfCert.exe.
Alternative method of locating SelfCert.exe
if you Can’t find it in the Start Menu? then By default you can find SelfCert.exe in the following location
Windows 32-bit
C:\Program Files\Microsoft Office\Office <version number>
Windows 64-bit with Office 32-bit
C:\Program Files (x86)\Microsoft Office\Office <version number>
Windows 64-bit with Office 64-bit
C:\Program Files\Microsoft Office\Office <version number>
Office 365 (Subscription based or Click-to-Run version of Office 2013)
C:\Program Files\Microsoft Office 15\root\office15
If SelfCert.exe is not installed
Then run Office setup and choose Add or Remove Features.
With older versions of Office you’ll need to choose Custom installation and then Advanced customization.
Expand the Office Shared Features section and select Digital Certificate for VBA Projects to run from your computer.
Simply run SelfCert.exe after locating it.
I'm using VBA for MS Access in order to link a small C# app to my database as a helper tool. I have tried a couple of different ideas from stackoverflow itself, including the ShellAndWait utility and another on that page.
I have a button on a form. When you click this button, it should run another application that I am currently storing in %APPDATA%/program/
This is the code that is currently active:
Private Sub BtnImport_Click()
Dim file As String
Dim hProcess as Long
file = Environ("APPDATA") & "\program\component_import.exe"
'This is the standard version, which apparently does nothing at this time.
hProcess = Shell(file, vbNormalFocus)
'This is the RunApplication version I got from here earlier. It ends
'with "Successfully returned -532462766
import_funcs.RunApplication(file)
'This is the ShellAndWait version, which gives me a "File not Found" error
import_funcs.ShellAndWait(file, 0, vbNormalFocus, AbandonWait)
End Sub
I had changed the original shell out for both the ShellAndWait module and another similar module. Neither of those options work any differently in terms of my application not starting.
I have double-checked that "file" is correct (It points to C:\Users\Me\AppData\Roaming\program\component_import.exe). I have double-checked to make sure that my app is in the correct location.
It runs fine if I double-click from file explorer. It says Run-time error '53': File not found. whenever I attempt to run it from MS Access.
Any suggestions?
Edit: As an aside, the path itself does not contain any spaces.
Edit: Added some additional code.
Link to first pastebin: RunApplication pastebin
Link to second pastebin: ShellAndWait pastebin
I found sometimes folder names with spaces throws error when using shell command.
eg: C:\My Folder\appl.exe
make it:
C:\MyFolder\appl.exe
Also can check for a valid path:
The following code checks the folder where chrome.exe residing and calling www.google.com from there by passing url as argument:
Public Sub Display_Google()
Dim chromePath As String
chromePath = "C:\Program Files\Google\Chrome\Application\chrome.exe"
If FileExists(chromePath) Then
Shell (chromePath & " -url" & " " & "www.google.com"), vbMaximizedFocus
Else
chromePath = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
Shell (chromePath & " -url" & " " & "www.google.com"), vbMaximizedFocus
End If
End Sub
Public Function FileExists(ByVal FileName As String) As Boolean
On Error Resume Next
FileExists = Not CBool(GetAttr(FileName) And (vbDirectory Or vbVolume))
On Error GoTo 0
End Function