I have a script comprising of batch files that generate powershell scripts. I've taken it upon myself to accomplish the same task via VB Script. So far I've assigned most of the info I need to strings. But I would like to have a prompt for a password that is stored as a secure string and can be outputted to a text file for later use in further scripts. So far the only code I've found doesn't work I think perhaps because it was intended for VB rather than VBS. Any help greatly appreciated.
The powershell code previously used was.
echo Please enter admin credentials (This will be stored in a secure string:
powershell -Command "& { read-host -assecurestring | convertfrom- securestring | out-file C:\S3BS\reports\input.txt; } "
You can use this small code with powershell and batch
#ECHO OFF
Title Type a password with powershell and batch
:CheckPassword
Mode con cols=50 lines=3
cls & color 0A & echo.
set MyPassword=Hackoo
set "psCommand=powershell -Command "$pword = read-host 'Enter your password' -AsSecureString ; ^
$BSTR=[System.Runtime.InteropServices.Marshal]::SecureStringToBSTR($pword); ^
[System.Runtime.InteropServices.Marshal]::PtrToStringAuto($BSTR)""
for /f "usebackq delims=" %%p in (`%psCommand%`) do set password=%%p
if %MyPassword%==%password% (Goto:Good) else (Goto:Bad)
exit/b
::***********************************************************************************************
:Good
Cls & Color 0A
echo(
echo Good Password
TimeOut /T 2 /NoBreak>nul
Exit
::***********************************************************************************************
:Bad
Cls & Color 0C
echo(
echo Bad password
TimeOut /T 1 /NoBreak>nul
Goto:CheckPassword
::***********************************************************************************************
I think this function PasswordBox can help you, just give a try ;)
' Just an example of how to use the function
'
wsh.echo "You entered: ", _
Join(PasswordBox("Enter UID and password", _
"Testing"), ", ")
' A function to present a Password dialog in a VBS (WSF)
' script
' Requires WScript version 5.1+
' Tom Lavedas <tlavedas#hotmail.com>
' with help from and thanks to Joe Ernest and
' Michael Harris
'
' modified 1/2008 to handle IE7
'
Function PasswordBox(sPrompt,sDefault)
set oIE = CreateObject("InternetExplorer.Application")
With oIE
' Configure the IE window
.RegisterAsDropTarget = False
.statusbar = false : .toolbar = false
.menubar = false : .addressbar = false
.Resizable = False
.Navigate "about:blank"
Do Until .ReadyState = 4 : WScript.Sleep 50 : Loop
' Test for IE 7 - cannot remove 'chrome' in that version
sVersion = .document.parentWindow.navigator.appVersion
if instr(sVersion, "MSIE 7.0") = 0 Then .FullScreen = True
.width = 400 : .height = 270
' Create the password box document
With .document
oIE.left = .parentWindow.screen.width \ 2 - 200
oIE.top = .parentWindow.screen.height\ 2 - 100
.open
.write "<html><head><" & "script>bboxwait=true;</" _
& "script><title>Password _</title></head>"_
& "<body bgColor=silver scroll=no " _
& "language=vbs style='border-" _
& "style:outset;border-Width:3px'" _
& " onHelp='window.event.returnvalue=false" _
& ":window.event.cancelbubble=true'" _
& " oncontextmenu=" _
& "'window.event.returnvalue=false" _
& ":window.event.cancelbubble=true'" _
& " onkeydown='if ((window.event.keycode>111)"_
& " and (window.event.keycode<117)) or" _
& " window.event.ctrlkey then" _
& " window.event.keycode=0" _
& ":window.event.cancelbubble=true" _
& ":window.event.returnvalue=false'" _
& " onkeypress='if window.event.keycode=13" _
& " then bboxwait=false'><center>" _
& "<div style='padding:10px;background-color:lightblue'>" _
& "<b> " & sPrompt & "<b> </div><p>" _
& "<table bgcolor=cornsilk cellspacing=10><tr><td>" _
& " <b>User:</b></td><td>" _
& "<input type=text size=10 id=user value='" _
& sDefault & "'>" _
& "</td><tr><td> <b>Password:</b></td><td>" _
& "<input type=password size=12 id=pass>" _
& "</td></tr></table><br>" _
& "<button onclick='bboxwait=false;'>" _
& " Okay " _
& "</button> <button onclick=" _
& "'document.all.user.value=""CANCELLED"";" _
& "document.all.pass.value="""";" _
& "bboxwait=false;'>Cancel" _
& "</button></center></body></html>"
.close
Do Until .ReadyState = "complete" : WScript.Sleep 100 : Loop
.all.user.focus
.all.user.select ' Optional
oIE.Visible = True
CreateObject("Wscript.Shell")_
.Appactivate "Password _"
PasswordBox = Array("CANCELLED")
On Error Resume Next
Do While .parentWindow.bBoxWait
if Err Then Exit Function
WScript.Sleep 100
Loop
oIE.Visible = False
PasswordBox = Array(.all.user.value, _
.all.pass.value)
End With ' document
End With ' IE
End Function
If you are executing the VBScript via cscript.exe something like;
cscript.exe /nologo "test.vbs"
You can use the WScript object to access the StdIn (for input) and StdOut (for output) streams to the command window using a script like this;
Function PromptForInput(prompt)
Dim prog : prog = WScript.Fullname
If LCase(Right(prog, 12)) = "\cscript.exe" Then
Call WScript.StdOut.WriteLine(prompt & " ")
PromptForInput = WScript.StdIn.ReadLine()
Else
Call Err.Raise(vbObjectError + 5, "Must be called from cscript.exe")
End If
End Function
Dim input
input = PromptForInput("Did you wish to continue? [Y/N]")
Select Case UCase(input)
Case "Y", "N"
Call WScript.StdOut.Writeline("You chose: " & UCase(input))
Case Else
Call WScript.StdOut.Writeline("Invalid option!")
End Select
Output:
Did you wish to continue? [Y/N]
y
You chose: Y
You can adapt it to prompt for passwords but be aware that the input is not hidden so all the characters typed are visible in the command window until it's closed.
Related
I'm using Excel to upload some files onto an server with WinSCP.
This example works:
Sub FTP_upload()
Dim logfile, ftp_login, file_to_upload, upload_to_folder As String
logfile = "D:\temp\ftp.log"
ftp_login = "ftp://ftp_mydomain:mypassword#mydomain.com/"
file_to_upload = "D:\tmep\myfile.txt"
upload_to_folder = "/myfolder/"
'upload the file
Call Shell("C:\Program Files (x86)\WinSCP\WinSCP.com /log=" & logfile & " /command " & """open """ & ftp_login & " " & """put " & file_to_upload & " " & upload_to_folder & """ " & """exit""")
End Sub
I now want Excel to wait until the shell has closed.
Using the information from Wait for shell command to complete, I put it together this code:
Sub FTP_upload_with_wait()
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Integer
Dim logfile, ftp_login, file_to_upload, upload_to_folder As String
logfile = "D:\temp\ftp.log"
ftp_login = "ftp://ftp_mydomain:mypassword#mydomain.com/"
file_to_upload = "D:\tmep\myfile.txt"
upload_to_folder = "/myfolder/"
execute_string = "C:\Program Files (x86)\WinSCP\WinSCP.com /log=" & logfile & " /command " & """open """ & ftp_login & " " & """put " & file_to_upload & " " & upload_to_folder & """ " & """exit"""
errorCode = wsh.Run(execute_string, windowStyle, waitOnReturn)
End Sub
Unfortunately, this doesn't work. Excel reports:
run-time error '-2147024894 (80070002)'
Automation error
The system cannot find the file specified
When I replace the string this way, it works:
execute_string = "notepad.exe"
It seems that wsh.Run doesn't like the quotation marks.
How can I make this work?
The path to WinSCP contains spaces, so you need to wrap it to double-quotes (which need to be doubled to escape them in VBA string):
execute_string = """C:\Program Files (x86)\WinSCP\WinSCP.com"" ..."
But that's only the first set of quotes that is wrong in your command.
The correct command would be like:
execute_string = """C:\Program Files (x86)\WinSCP\WinSCP.com"" " & _
"/log=" & logfile & " /command " & _
"""open " & ftp_login & """ " & _
"""put " & file_to_upload & " " & upload_to_folder & """ " & _
"""exit"""
Assuming that none of logfile, ftp_login, file_to_upload and upload_to_folder contains spaces, in which case would would need a way more double-quotes.
Read ore about WinSCP command-line syntax
The Call Shell must have some heuristics that adds the quotes around C:\Program Files (x86)\WinSCP\WinSCP.com. Though it's just a pure luck that the rest of the command-line works, the quotes are wrong there too. So even your first code is wrong. It runs the following command:
"C:\Program Files (x86)\WinSCP\WinSCP.com" /log=D:\temp\ftp.log /command "open "ftp://ftp_mydomain:mypassword#mydomain.com/ "put D:\tmep\myfile.txt /myfolder/" "exit"
(Note the misplaced quotes around open)
I'd like to make a VBA code in excel but I'm stuck. I want it to take my worksheet where I have several pages to print (50 pages in one worksheet).
On every print page there is a sum and if that sum is greater than 0 I want to convert that page to a pdf and send the print page to the email on the page (so it's different emails).
The sum is in F22 and email is in B8 on page 1.
The sum is in F72 and email is in B58 on page 2.
So the range changes by 50 rows every page.
The emails area is B2:F50 on first page and B52:F100 on second page, B102:F150 on the third.
I have tried but can only do it with 1 page and 1 email.
here is the code i have, work for 1 page
Sub RDB_Selection_Range_To_PDF_And_Create_Mail()
Dim Charge As Integer
Charge = ThisWorkbook.Sheets("Crosscharge").Cells(23, 6).Value
If Charge > 0 Then
Dim FileName As String
If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "There is more then one sheet selected," & vbNewLine & _
"ungroup the sheets and try the macro again"
Else
'Call the function with the correct arguments
'For a fixed range use this line
FileName = RDB_Create_PDF(Source:=Range("B2:F50"), _
FixedFilePathName:="", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
If FileName <> "" Then
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:="Email", _
StrCC:="", _
StrBCC:="", _
StrSubject:="Text", _
Signature:=True, _
Send:=False, _
StrBody:="<H3><B>Dear Customer</B></H3><br>" & _
"<body>See the attached PDF file with the." & _
"<br><br>" & "Kind regards</body>"
Else
MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
"Microsoft Add-in is not installed" & vbNewLine & _
"You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
"The path to Save the file in arg 2 is not correct" & vbNewLine & _
"You didn't want to overwrite the existing PDF if it exist"
End If
End If
End Sub
Hope you can help
What you need to do is implement a loop. The fact that your cells are exactly 50 apart for each page makes this very easy for your code. Another note that I see if that you assign the value in cell F23 to an Integer at the very beginning. Unless you can guarantee that it will always be an integer (for example you're rounding) it might be better to define it as Double Also the Integer type can only hold numbers between ~ - 2 billion and 2 billion. If you might be dealing with numbers larger then that use Long.
I was unable to test this code in it's entirety because you call on some custom functions, but try this. If there are any issues let me know and I will update this code.
Sub RDB_Selection_Range_To_PDF_And_Create_Mail()
Dim Charge As Long
Dim LastRow As Long
Dim FileName As String
Dim i As Long
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "There is more then one sheet selected," & vbNewLine & _
"ungroup the sheets and try the macro again"
End If
i = 23
Do While i <= LastRow
Charge = ThisWorkbook.Sheets("Crosscharge").Cells(i, 6).Value
If Charge > 0 Then
'Call the function with the correct arguments
'For a fixed range use this line
FileName = RDB_Create_PDF(Source:=Range("B2:F" & i + 27), _
FixedFilePathName:="", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
If FileName <> "" Then
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:="Email", _
StrCC:="", _
StrBCC:="", _
StrSubject:="Text", _
Signature:=True, _
Send:=False, _
StrBody:="<H3><B>Dear Customer</B></H3><br>" & _
"<body>See the attached PDF file with the." & _
"<br><br>" & "Kind regards</body>"
Else
MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
"Microsoft Add-in is not installed" & vbNewLine & _
"You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
"The path to Save the file in arg 2 is not correct" & vbNewLine & _
"You didn't want to overwrite the existing PDF if it exist"
End If
End If
i = i + 50
Loop
End Sub
I am trying to open a form with criteria.
My criteria where I am getting the error.
strCriteria = "WorkID = 3 And
OptOut= -1 And
AppointmentDate = (Last(AppointmentDate))>DateSerial(Year(Date()),Month(Date())-3,1) And
(Last(AppointmentDate))<DateSerial(Year(Date()),Month(Date())-2,0)"
I placed it like this in order to read it easier.
My error number is 3096.
Thank you.
==== Update I give up =======
My code so far.
strSQL = "SELECT tblAppointment.WorkID," & _
"tblCustomer.OptOut," & _
"Last(tblAppointment.AppointmentDate) AS LastAppointmentDate," & _
"tblAppointment.CustomerID," & _
"tblCustomer.Surname," & _
"tblCustomer.Name," & _
"tblCustomer.FatherName," & _
"Last(tblAppointment.AppointmentMemo) AS LastAppointmentMemo" & _
"FROM tblCustomer INNER JOIN tblAppointment ON tblCustomer.CustomerID = tblAppointment.CustomerID " & _
"GROUP BY tblAppointment.WorkID," & _
"tblCustomer.OptOut," & _
"tblAppointment.CustomerID," & _
"tblCustomer.Surname," & _
"tblCustomer.Name," & _
"tblCustomer.FatherName " & _
"HAVING (((tblAppointment.WorkID) = 3) And ((tblCustomer.OptOut) = -1) And " & _
"(LastAppointmentDate > DateSerial(Year(Date()), Month(Date()) - 3, 1) And " & _
"LastAppointmentDate < DateSerial(Year(Date()), Month(Date()) - 2, 0)))" & _
"ORDER BY LastAppointmentDate, " & _
"tblCustomer.Surname," & _
"tblCustomer.Name," & _
"tblCustomer.FatherName;"
I see you are still having trouble. Let's look at the code you have given us.
Your having statement is looking for a field that does not exist on the table. You currently have:
Having (((tblAppointment.WorkID) = 3) And ((tblCustomer.OptOut) = -1) And " & _
"(LastAppointmentDate > DateSerial(Year(Date()), Month(Date()) - 3, 1) And " & _
"LastAppointmentDate < DateSerial(Year(Date()), Month(Date()) - 2, 0)))" & _
Your having clause is looking for LastAppointmentDate on your table. This field does not exist since the field name is AppointmentDate. Change your field name in your having statement to match the field name and it should work. You also have missing parenthesis.
Having (((tblAppointment.WorkID) = 3) AND ((tblCustomer.optout) = -1) AND " & _
"((tblAppointment.AppointmentDate) > DateSerial(Year(Date()), Month(Date()),-3,1)) AND " & _
"((tblAppointment.AppointmentDate) < DateSerial(Year(Date()), Month(Date()),-2,0))) " & _
Try this solution to your having statement. If it does not work, let me know and I'll do more digging.
There isn't much information to go off of with your question, but I'm going to take a stab at it.
I'm assuming you are trying to open a form with the following code:
docmd.openform "FormName",acnormal,,strcriteria
If this is the case, you variable is looking for a last appointment date that hasn't been established or discovered yet. basically, you set a criteria to a field on a form that isn't loaded yet, thus, no information can be used.
You can try a different approach that has done justice for me multiple times and I continue to use this method today.
private sub Eventtrigger()
dim frm as form
dim strSQL as string
strsql = "SELECT * " & _
"FROM TableName " & _
"WHERE (((TableName.workID) = 3 AND (TableName.OptOut) = -1 AND (TableName.AppointmentDate) > DateSerial(year(date()),Month(Date())-3,1) AND (TableName.AppointmentDate) < DateSerial(year(date()),Month(date())-2,0)));"
'Edited since I missed 2 closing parenthesis
Docmd.openform "FormName",acnormal
set frm = [forms]![FormName] 'New form opened
frm.recordsource = strsql
EndCode:
if not frm is nothing then
set frm = nothing
end if
end sub
The above code will allow you to set the recordsource of the form to the newly created query. which the query will filter the results for you.
Or, to fix you variable, Just set your variable as follows:
strcriteria = "WorkID = 3 AND OptOut = -1 AND " & _
"AppointmentDate > DateSerial(Year(date()),Month(date())-3,1) AND " & _
"AppointmentDate < DateSerial(Year(date()),Month(date())-2,0)"
If you need last, use last on AppointmentDate:
Last(AppointmentDate) > DateSerial(Year(date()),Month(Date())-3,1) AND " & _
Last(AppointmentDate) < DateSerial(Year(date()),Month(Date())-2,0)
Let me know if either of these methods/repairs didn't work and I will do more digging.
I'm trying to attach a vbscript onto my windows scheduler so that as soon as I open a program (for example, Google Chrome) it runs an excel macro in the background. I've looked into task scheduler and can't find the ability to trigger events based on opening another program, as opposed to an administrative message or error. Sorry for the noob question!
This is from Windows SDK WMI section. http://msdn.microsoft.com/en-us/library/aa392396(v=vs.85).aspx
This monitors 6 (i=0 to 5) program starts and exits.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" _
& strComputer & "\root\CIMV2")
Set objEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM Win32_ProcessTrace")
Wscript.Echo "Waiting for events ..."
i = 0
Do Until i=5
Set objReceivedEvent = objEvents.NextEvent
'report an event
Wscript.Echo "Win32_ProcessTrace event occurred" & VBNewLine _
& "Process Name = " _
& objReceivedEvent.ProcessName & VBNewLine _
& "Process ID = " _
& objReceivedEvent.Processid & VBNewLine _
& "Session ID = " & objReceivedEvent.SessionID
i = i+ 1
Loop
I have a simple script that monitors processes' different performance statistics in Windows XP in a loop until it is terminated.
Despite my efforts, the script's memory footprint increases in size over time.
Any advice is greatly appreciated.
Set fso = CreateObject("Scripting.FileSystemObject")
logFileDirectory = "C:\POSrewrite\data\logs"
Dim output
Dim filePath
filePath = "\SCOPerformance-" & Day(Now()) & Month(Now()) & Year(Now()) & ".log"
IF fso.FolderExists(logFileDirectory) THEN
ELSE
Set objFolder = fso.CreateFolder(logFileDirectory)
END IF
logFilePath = logFileDirectory + filePath + ""
IF (fso.FileExists(logFilePath)) THEN
set logFile = fso.OpenTextFile(logFilePath, 8, True)
output = VBNewLine
output = output & (FormatDateTime(Now()) + " Open log file." & VBNewLine)
ELSE
set logFile = fso.CreateTextFile(logFilePath)
output = output & (FormatDateTime(Now()) + " Create log file." & VBNewLine)
END IF
output = output & (FormatDateTime(Now()) + " Begin Performance Log data." & VBNewLine)
output = output & ( "(Process) (Percent Processor Time) (Working Set(bytes)) (Page Faults Per Second) (PrivateBytes) (PageFileBytes)" & VBNewLine)
WHILE (True)
On Error Resume NEXT
IF Err = 0 THEN
strComputer = "."
Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Set objServicesCimv2 = GetObject("winmgmts:\\" _
& strComputer & "\root\cimv2")
Set objRefreshableItem = _
objRefresher.AddEnum(objServicesCimv2 , _
"Win32_PerfFormattedData_PerfProc_Process")
objRefresher.Refresh
' Loop through the processes three times to locate
' and display all the process currently using
' more than 1 % of the process time. Refresh on each pass.
FOR i = 1 TO 3
objRefresher.Refresh
FOR Each Process in objRefreshableItem.ObjectSet
IF Process.PercentProcessorTime > 1 THEN
output = output & (FormatDateTime(Now()) & "," & i ) & _
("," & Process.Name & _
+"," & Process.PercentProcessorTime & "%") & _
("," & Process.WorkingSet) & ("," & Process.PageFaultsPerSec) & _
"," & Process.PrivateBytes & "," & Process.PageFileBytes & VBNewLine
END IF
NEXT
NEXT
ELSE
logFile.WriteLine(FormatDateTime(Now()) + Err.Description)
END IF
logFile.Write(output)
output = Empty
set objRefresher = Nothing
set objServicesCimv2 = Nothing
set objRefreshableItem = Nothing
set objFolder = Nothing
WScript.Sleep(10000)
Wend
I think the main problem with your script is that you initialize WMI objects inside the loop, that is, on every iteration of the loop, even though these objects are always the same:
strComputer = "."
Set objRefresher = CreateObject("WbemScripting.SWbemRefresher")
Set objServicesCimv2 = GetObject("winmgmts:\\" _
& strComputer & "\root\cimv2")
Set objRefreshableItem = _
objRefresher.AddEnum(objServicesCimv2 , _
"Win32_PerfFormattedData_PerfProc_Process")
You need to move this code out of the loop, e.g., at the beginning of the script.
Other tips and suggestions:
Use Option Explicit and explicitly declare all variables used in your script. Declared variables are slightly faster than undeclared ones.
Use FileSystemObject.BuildPath to combine multiple parts of the path. The useful thing about this method is that it inserts the necessary path separators for you.
logFileDirectory = "C:\POSrewrite\data\logs"
filePath = "SCOPerformance-" & Day(Now) & Month(Now) & Year(Now) & ".log"
logFilePath = fso.BuildPath(logFileDirectory, filePath)
The objFolder variable isn't used in your script, so there's no need to create it. Also, you can make the FolderExists check more readable by rewriting it as follows:
If Not fso.FolderExists(logFileDirectory) Then
fso.CreateFolder logFileDirectory
End If
Move repeated code into subroutines and functions for easier maintenance:
Function DateTime
DateTime = FormatDateTime(Now)
End Function
...
output = output & DateTime & " Open log file." & vbNewLine
Usually you don't need parentheses when concatenating strings:
output = output & DateTime & "," & i & _
"," & Process.Name & _
"," & Process.PercentProcessorTime & "%" & _
"," & Process.WorkingSet & "," & Process.PageFaultsPerSec & _
"," & Process.PrivateBytes & "," & Process.PageFileBytes & vbNewLine
In this article, Eric Lippert (Literally worked on designing and building VBScript at Microsoft) indicates that the order in which you dispose of things may be important. Maybe you are running into one of these bugs?
I'll let you read the rest...
When Are You Required To Set Objects To Nothing?
I would recommend against running the script in a permanent loop within the script unless you actually need such a tight loop. I would suggest a single iteration within in the script, called from Scheduled tasks.
I have run into the exact same issue, using it for a procmon-style attempt to capture a rogue process that appears to be respawning.
Narrowing it all down, it appears to be the objRefresher.Refresh and there simply appears to be no way around it
What I did to overcome this was use a for...next to run it 100 times, then immediately afterwards run the following, which would simply respawn the script and shutdown:
CreateObject("Wscript.Shell").Run """" & WScript.ScriptFullName & """", 0, False
So I would watch the memory crawl from 5Mb to 40Mb, then drop back down to 5Mb