I'd like to run my VBScript code written in EA from command line (as a night job). Is there a way to do it except copying it to .vbs file and run it like this? I have a bunch of !INC-ludes in the script and that would mean double maintenance effort to keep both versions up-to-date. Is there a solution?
No out-of-the-box solution is available here. But you can write VBScript code to mimic what EA does, when it runs the script, i.e.
retrieve the script code from t_script table
retrieve all icludes (!INC script_group.script_name)
replace the !INC lines with the included script text
put the script into temporary .VBS file and run it
Further, you need to provide replacement for all the features readily available in EA when running a script, at least
create instance of the Repository object as global variable
replace all the Session.Output statements to get output to the console (alternatively, you may implement and instantiate your own Session class)
As EA is a 32-bit application, you need to call 32-bit version of the scripting engine (cscript.exe) to run the script communicating with EA API, usualy at C:\Windows\SysWOW64\cscript.exe
All the tasks above are compiled into the following script code:
option explicit
'(c) Martin Jecny 2020
'WScript.Echo "Scripting Engine: " & ScriptEngine & " ver. " & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion
'WScript.Echo "Creating Repository object"
dim Repository 'as EA.Repository 'defined as global, as it is default in EA environment
set Repository=CreateObject("EA.Repository")
dim ses 'as EA.Session
WScript.Echo "Start: " & Now
runIt(WScript.Arguments) 'complete script name, -v|--verbose
WScript.Echo "End: " & Now
'cleanup
on error resume next
Repository.exit
set Repository=Nothing
on error goto 0
sub runIt(argList)
dim result 'as Variant
if argList.Count <1 then
WScript.Echo "Usage: runEaScript <scriptGroup>.<scriptName> [-v|--verbose] [-c|--copysource]"
result=cleanup(Nothing)
WScript.Quit(0)
end if
'parse arguments
dim scriptFullName 'as String
scriptFullName=argList(0)
dim arg
dim verbose 'as Boolean
verbose=false
dim copysource 'as Bollean
copysource=false
for each arg in argList
select case arg
case "-v", "--verbose"
WScript.Echo "Verbose mode on"
verbose=true
case "-c", "--copysource"
copysource=true
if verbose then
WScript.Echo "Copy of the produced code will be stored to current directory"
end if
end select
next
if verbose then WScript.Echo "Requested script to run: '" & scriptFullName & "'"
if verbose then WScript.Echo "Opening cloud Repository ..."
Repository.OpenFile ("mycloudrepository --- ;Connect=Cloud=protocol:http,address:cloudhost,port:80;Data Source=modelname;DSN=modelname;LazyLoad=1;")
if verbose then WScript.Echo "Retrieving main script code ..."
dim sql 'as String
dim mainScriptCode 'as String
mainScriptCode=getScriptCode(scriptFullName)
if Len(mainScriptCode)<1 then
WScript.Echo "500002" & ": " & "Main script code retrieval failed."
result=cleanup(Nothing)
WScript.Quit(3)
end if
if verbose then WScript.Echo "Resolving !INCludes ..."
dim startPos 'as Integer 'position of !INC in the code
dim endOfPreviousLinePos 'as Integer 'position before start of the !INC line
dim startToInc 'as String ' string between start of line and !INC directive
dim endLinePos 'as Integer 'end position of !INC line
dim endIncPos 'as Integer 'end of included script name within the line
startPos=1 'start position of !INC in script code
endLinePos=0
endIncPos=0
dim includeList 'as Scripting.Dictionary 'list of already included scripts
set includeList=CreateObject("Scripting.Dictionary")
includeList.RemoveAll
dim includeString 'as String '!INC <script> string
dim toBeReplaced 'as String 'usualy full line with !INC string
do while startPos<>0
'detect !INC
startPos = InStr(1,mainScriptCode,"!INC ")
'detection and removal of !INC within commented line
if startPos > 0 then
endLinePos=InStr(startPos,mainScriptCode,chr(10))
endOfPreviousLinePos=InStrRev(mainScriptCode, chr(10),startPos)
if endOfPreviousLinePos <> (startPos-1) then
startToInc=mid(mainScriptCode,endOfPreviousLinePos,startPos-endOfPreviousLinePos)
if InStr(startToInc,"'")>0 then
if verbose then WScript.Echo "Skipping commented reference " & startToInc & toBeReplaced
toBeReplaced=mid(mainScriptCode,startPos,endLinePos-startPos)
mainScriptCode=Replace(mainScriptCode,toBeReplaced,"",1,1)
startPos=InStr(1,mainScriptCode,"!INC ")
end if
end if
end if
'including the code if not already included
if startPos > 0 then
endLinePos=InStr(startPos,mainScriptCode,chr(10))
includeString=trim(mid(mainScriptCode,startPos+5,endLinePos-(startPos+5))) 'ommit !INC string
toBeReplaced=mid(mainScriptCode,startPos,endLinePos-startPos)
'remove comment from reference line
endIncPos=InStr(1,includeString,"'") 'comment?
if endIncPos>0 then 'strip comment after reference
includeString=left(includeString,endIncPos-1)
end if
includeString=trim(includeString)
Err.Clear 'probably not necessary, just for sure
on error resume next
includeList.Add includeString,includeString 'Dictionary object has natively unique index
if Err.Number >0 then 'already exists
if verbose then WScript.Echo includeString & " already included, removing the reference."
mainScriptCode=Replace(mainScriptCode,toBeReplaced,"",1,1)
else 'new one found
if verbose then WScript.Echo "Including '" & includeString & "'"
mainScriptCode=Replace(mainScriptCode,toBeReplaced,getScriptCode(includeString),1,1)
end if
on error goto 0
end if
loop
'adapt code for running in pure VBS environment
if verbose then WScript.Echo "Adapting the code ..."
mainScriptCode=adaptToPureVbsCode(mainScriptCode)
'make file with the code to run
dim tempFileName 'as String
dim fso 'as Scripting.FileSystemObject
dim tempFolder 'as Folder
set fso=CreateObject("Scripting.FileSystemObject")
set tempFolder=fso.GetSpecialFolder(2) 'get temp diectory
tempFileName=fso.GetSpecialFolder(2).Path & "\" & fso.getTempName
dim mainScriptFile 'as File
set mainScriptFile=fso.createTextFile(tempFileName)
result=mainScriptFile.Write(mainScriptCode) '#TODO error handling
result=mainScriptFile.Close
if verbose then WScript.Echo "Written to file: " & tempFileName
if copysource then
dim scriptdir 'as Folder
scriptdir = fso.GetParentFolderName(WScript.ScriptFullName)
result=fso.CopyFile (tempFileName, scriptdir & scripFullName& ".vbs",true) 'overwrite allowed
end if
executeGlobal fso.openTextFile( tempFileName).readAll() 'run the complete script from temporary file
if verbose then Wscript.Echo "000000" & ": " & "Successful exit"
WScript.Quit(0)
end sub
function getScriptCode(scriptFullName)
if Len(scriptFullName)<1 then
WScript.Echo "500001" & ": " & "No script name provided"
getScriptCode=""
exit function
end if
if InStr(scriptFullName,".")<2 then
WScript.Echo "500004" & ": " & "No group - provide full script name in the form <Group>.<Script>"
getScriptCode=""
exit function
end if
dim dotPos 'as Integer
dotPos=InStr(scriptFullName,".")
dim scriptGroupName 'as String
dim ScriptName 'as String
scriptGroupName=Left(scriptFullName,dotPos-1)
scriptName=Mid(scriptFullName,dotPos+1)
if Len(scriptName)<1 then
WScript.Echo "500005" & ": " & "No script name - provide full script name in the form <Group>.<Script>"
getScriptCode=""
end if
dim sql
sql="select s.script from t_script s, t_script g where s.scriptauthor=g.scriptname"
sql = sql & " and g.script like '" & scriptGroupName & "'"
sql = sql & " and s.notes like '%Script Name=""" & scriptName & """%'"
dim scriptCode 'as String
getScriptCode=getSqlSingleValue(sql)
end function
'* adapts the code to run in pure VBS outside of EA
'* #param String 'original EA VBS code
'* #return String 'code with replacements
function adaptToPureVbsCode(code) '#TODO: replacement for Session.Input and Session.Prompt
dim regEx 'as RegExp
set regEx=New RegExp
regEx.IgnoreCase=true
regEx.Global=true
regEx.Pattern=chr(10)
'beautification of the code, mainly for debug purposes
code=regEx.Replace(code,chr(13) & chr(10))
'redirect outuput commands
regEx.Pattern="session.output" 'replace output command
code=regEx.Replace(code,"WScript.Echo")
'comment out manipulation with script output window
regEx.Pattern="Repository.EnsureOutputVisible \""Script\"""
code=regEx.Replace(code,"'"& "Repository.EnsureOutputVisible ""Script""")
regEx.Pattern="Repository.ClearOutput \""Script\"""
code=regEx.Replace(code,"'Repository.ClearOutput ""Script""")
adaptToPureVbsCode=code
end function
'* returns single (or first) value from single column; SQL query must comply to this; returns empty string if not found
'* #param sql as String SQL query
'* #return String
public function getSqlSingleValue(sql) 'as String
dim xmlDoc 'as MSXML2.DomDocument60 '1.2.0
set xmlDoc=CreateObject("Msxml2.DOMDocument.6.0") '1.2.0
dim node 'as MSXML2.IXMLDomNode
xmlDoc.loadXML(Repository.SQLQuery(sql)) '#TODO fails with field names like COUNT(*) on "("; needs escaping
set node= xmlDoc.selectSingleNode("//Row[1]/child::node()")
if node is nothing then
getSqlSingleValue=""
exit function
end if
if len(node.text)>0 then
getSqlSingleValue=node.text
else
getSqlSingleValue=""
end if
end function
'*# Cleanup of the environment
'*#param FileSystemObject fso
'*#return void
function cleanup(fso)
on error resume next
Repository.CloseFile
Repository.Exit
set Repository=nothing
result=fso.DeleteFile(tempFileName)
set fso=nothing
on error goto 0
end function
Script Usage
"C:\Windows\SysWOW64\cscript.exe" "C:\Users\user\Documents\jobs\runEaScript.vbs" "my Script Group.My Script Name" --verbose /nologo
It has to be noted, that VBScript's text operations are not extermely fast and script preparation may take some time. Should you need to run the script very often, implement some caching of the resulting VBS file.
Related
I'm trying to copy all filenames list on the Recycle Bin in Windows 10.
I go to Command Prompt:
C:\>cd C:/$Recycle.Bin
C:\$Recycle.Bin>dir S-1-5-21-2370250818-2711005194-4184312249-1165
$R8CQG1I.txt
$IURO2ZD.txt
$RV2TEJ7.txt
I have 3 files I want to copy the real file names not the names like this result.
After some search I found this VBScript. I run the code and I get this error:
Expected end of statement
Option Explicit
DIM g_objWshShell, g_objFSO, g_sLogFile, g_objWshNetwork, g_sScriptName, g_sComputerName, g_sUserName Dim g_sVer, g_objLogFile, g_sLogDir
'Setup main variables and objects Set g_objWshShell = WScript.CreateObject("WScript.Shell") 'Create a Shell Object Set g_objFSO = CreateObject("Scripting.FileSystemObject") 'create a File System Object Set g_objWshNetwork = WScript.CreateObject("WScript.Network") 'Create Network Object g_sComputerName
= g_objWshNetwork.Computername 'Gets machine Computer name g_sUserName = g_objWshNetwork.UserName 'Gets logged-on username g_sScriptName=UCase(WScript.ScriptName) '
*** Name of the script
' *** START LogFile Information - use Delete or Append info below; don't use both *** Const FORREADING = 1, FORWRITING = 2, FORAPPENDING
= 8 'Setup constants for writing, appending, etc g_sLogDir = "C:\TEMP" If Not (g_objFSO.FolderExists(g_sLogDir)) Then g_objFSO.CreateFolder(g_sLogDir) End If g_sLogFile = g_sLogDir & "\" & Left(g_sScriptName,len(g_sScriptName)
- 3) & "LOG" 'Makes log file the SCRIPTNAME.Log g_sVer = "1.0"
'To delete a logfile and create a new one each time script is ran If g_objFSO.FileExists(g_sLogFile) Then g_objFSO.DeleteFile(g_sLogFile) 'Delete logfile if it exists. End If Set g_objLogFile = g_objFSO.CreateTextFile(g_sLogFile, FORWRITING) 'Setup the logfile for writing
Call Main() Call ExitScript()
'Start main script HERE *** Sub Main() Dim objRecycleBin, objFolderItems, objItem, strSpecialFolderName strSpecialFolderName = "Recycle Bin" 'Call WriteLine("Starting " & g_sScriptName & " at " & Date & " " & Time, g_objLogFile) Set objRecycleBin
= GetSpecialFolderObject(strSpecialFolderName) 'Get Special Folder based upon input name Set objFolderItems = objRecycleBin.Items() 'Get items within Recycle Bin For Each objItem In objFolderItems 'Delete all items within Special Folder If (objItem.Type = "File Folder") Then 'Check for file type g_objFSO.DeleteFolder(objItem.Path) 'Delete Folders Else g_objFSO.DeleteFile(objItem.Path) 'Delete Files End If WScript.Echo "Deleted " & objItem.Name Next End Sub
'*-*-*-*-*- Start Subroutines here
*-*-*-*-*- 'Returns SpecialFolder based upon name of folder Function GetSpecialFolderObject(NameOfFolder) Dim objShellApp, i, objSpecialFolder Set objShellApp = CreateObject("Shell.Application") On Error Resume Next For i=0 To 40 '40 is highest value for special folders Set objSpecialFolder = objShellApp.NameSpace(i) If (StrComp(objSpecialFolder.Title,NameOfFolder,vbTextCompare)=0) Then Set GetSpecialFolderObject = objSpecialFolder Exit For End If Next Err.Clear End Function
'Closes logfile and exits script Sub ExitScript() 'Call WriteLine(Date & " " & Time & "; Completed " & g_sScriptName, g_objLogFile) If IsObject(g_objLogFile) Then
g_objLogFile.Close End If Wscript.Quit End Sub
Sub EndOnError(sErrorString) WScript.Echo sErrorString & vbcrlf & "Check " & chr(34) & g_sLogFile & Chr(34) & " for details" Call WriteLine (sErrorString, g_objLogFile) WScript.Quit() End Sub
'Shows usage if input is wrong sub ShowUsage() WScript.Echo g_sScriptName & " v" & g_sVer & " Empties Recycle Bin for logged on user" & vbcrlf _ & vbcrlf & "USAGE: [CSCRIPT] " & g_sScriptName WScript.Quit end sub
'Writes to log Sub WriteLine(ByVal strMessage, ByVal objFile)
On Error Resume Next
If IsObject(objFile) then 'objFile should be a file object
objFile.WriteLine strMessage
Else
Call Wscript.Echo( strMessage )
End If End Sub
The VBScript version of #boxdog answer:
Set objShellApp = CreateObject("Shell.Application")
Set objSpecialFolder = objShellApp.NameSpace(10) '10 = Recyle Bin
For Each objFolder In objSpecialFolder.Items
WScript.Echo "FileName = " & objFolder.Name & vbTab & "Original Path = " & objFolder.ExtendedProperty("{9B174B33-40FF-11D2-A27E-00C04FC30871} 2")
Next
Answering this in case anyone is looking for VBS only solution.
In PowerShell, you can list the current path and original name/location of the Recycle Bin contents like This:
$shell = New-Object -ComObject Shell.Application
$shell.NameSpace(0x0a).Items() |
Select-Object #{Label="OriginalLocation";Expression={$_.ExtendedProperty("{9B174B33-40FF-11D2-A27E-00C04FC30871} 2")}},Name, Path
To copy the items, you can do this:
$shell.NameSpace(0x0a).Items() |
Copy-Item -Destination "C:\RecoveredFiles\$($_.Name)" -Recurse -Force
Note that this doesn't take into account any name-clashes - you'll need to test for that and adjust accordingly.
Is there a way to write anonymous functions, pass them to other functions, in which they are invoked, in vbscript?
There are no anonymous functions/subs/methods in VBScript.
You can use GetRef() (see sample1, sample2) to get something like a function pointer that can be passed to functions/subs to be invoked there (callback). But there are no closures in VBScript, so tricks possible in other languages fail in VBScript.
For specific problems that can be solved with higher order functions in functional languages there may be (nearly) equivalent VBScript solutions involving classes/objects; but for discussing that approach you need to describe your/such a problem in detail.
VBScript has the ability to execute arbitatry code.
Execute and Eval just do what they say to a string containing code.
ExecuteGlobal adds code to your program, like a new function, new variables.
Script Control adds vbscript/jscript scripting language to any program including vbscripts. It can have access to the host's data.
If using ExecuteGlobal/Execute/Eval it is best to run through a scriptcontrol first to test for syntax errors (as you can't trap syntax errors, but you can trap the runtime error the script control gives off on a syntax error).
So you can build your program at runtime.
Set Arg = WScript.Arguments
set WshShell = createObject("Wscript.Shell")
Set Inp = WScript.Stdin
Set Outp = Wscript.Stdout
Sub VBSCmd
RawScript = LCase(Arg(1))
'Remove ^ from quoting command line and replace : with vbcrlf so get line number if error
Script = Replace(RawScript, "^", "")
Script = Replace(Script, "'", chr(34))
Script = Replace(Script, ":", vbcrlf)
'Building the script with predefined statements and the user's code
Script = "Dim gU" & vbcrlf & "Dim gdU" & vbcrlf & "Set gdU = CreateObject(" & chr(34) & "Scripting.Dictionary" & chr(34) & ")" & vbcrlf & "Function UF(L, LC)" & vbcrlf & "Set greU = New RegExp" & vbcrlf & "On Error Resume Next" & vbcrlf & Script & vbcrlf & "End Function" & vbcrlf
'Testing the script for syntax errors
On Error Resume Next
set ScriptControl1 = wscript.createObject("MSScriptControl.ScriptControl",SC)
With ScriptControl1
.Language = "VBScript"
.UseSafeSubset = False
.AllowUI = True
.AddCode Script
End With
With ScriptControl1.Error
If .number <> 0 then
Outp.WriteBlankLines(1)
Outp.WriteLine "User function syntax error"
Outp.WriteLine "=========================="
Outp.WriteBlankLines(1)
Outp.Write NumberScript(Script)
Outp.WriteBlankLines(2)
Outp.WriteLine "Error " & .number & " " & .description
Outp.WriteLine "Line " & .line & " " & "Col " & .column
Exit Sub
End If
End With
ExecuteGlobal(Script)
'Remove the first line as the parameters are the first line
'Line=Inp.readline
Do Until Inp.AtEndOfStream
Line=Inp.readline
LineCount = Inp.Line
temp = UF(Line, LineCount)
If err.number <> 0 then
outp.writeline ""
outp.writeline ""
outp.writeline "User function runtime error"
outp.writeline "==========================="
Outp.WriteBlankLines(1)
Outp.Write NumberScript(Script)
Outp.WriteBlankLines(2)
Outp.WriteLine "Error " & err.number & " " & err.description
Outp.WriteLine "Source " & err.source
Outp.WriteLine "Line number and column not available for runtime errors"
wscript.quit
End If
outp.writeline temp
Loop
End Sub
Vbs
filter vbs "text of a vbs script"
filter vb "text of a vbs script"
Use colons to seperate statements and lines. Use single quotes in place of double quotes, if you need a single quote use chr(39). Escape brackets and ampersand with the ^ character. If you need a caret use chr(136).
The function is called UF (for UserFunction). It has two parameters, L which contains the current line and LC which contains the linecount. Set the results of the script to UF. See example.
There are three global objects available. An undeclared global variable gU to maintain state. Use it as an array if you need more than one variable. A Dictionary object gdU for saving and accessing previous lines. And a RegExp object greU ready for use.
Example
This vbs script inserts the line number and sets the line to the function UF which Filter prints.
filter vbs "uf=LC ^& ' ' ^& L"<"%systemroot%\win.ini"
This is how it looks in memory
Dim gU
Set gdU = CreateObject("Scripting.Dictionary")
Set greU = New RegExp
Function UF(L, LC)
---from command line---
uf=LC & " " & L
---end from command line---
End Function
If there is a syntax error Filter will display debugging details.
User function syntax error
==========================
1 Dim gU
2 Dim gdU
3 Set greU = CreateObject("Scripting.Dictionary")
4 Function UF(L, LC)
5 On Error Resume Next
6 uf=LC dim & " " & L
7 End Function
Error 1025 Expected end of statement
Line 6 Col 6
User function runtime error
===========================
1 Dim gU
2 Dim gdU
3 Set greU = CreateObject("Scripting.Dictionary")
4 Function UF(L, LC)
5 On Error Resume Next
6 uf=LC/0 & " " & L
7 End Function
Error 11 Division by zero
Source Microsoft VBScript runtime error
Line number and column not available for runtime errors
the funny thing about function objects is that they by definition are a memory leak. This means that once you create a function object, you need to keep the scope it was created in intact, which threw me off.
Class VBCompiler
Public leaks
Public Sub Class_Initialize()
leaks = Array()
End Sub
Public Function Compile(code)
Dim compiler, result
Set compiler = CreateObject("MSScriptControl.ScriptControl")
Set portal = CreateObject("Scripting.Dictionary")
Dim name
compiler.Language = "VBScript"
compiler.AddObject "portal", portal, True
compiler.ExecuteStatement code
name = compiler.Procedures(1).Name
compiler.ExecuteStatement "portal.Add ""result"", GetRef(""" & name & """)"
' save the script control because if we go out of scope...
' our function object goes poof!
' leaks.Push compiler
ReDim Preserve leaks(UBound(leaks) + 1)
Set leaks(UBound(leaks)) = compiler
Set Compile = portal("result")
End Function
End Class
Dim z
Set z = New VBCompiler
Set z2 = z.Compile("Function Foo(s):MsgBox s:Foo = 2:End Function")
z2("Hi!")
z2 "Hello Again!"
Gives the two message boxes as desired
Class VBCompiler
Public Function Compile(code)
Dim compiler, result
Set compiler = CreateObject("MSScriptControl.ScriptControl")
Set portal = CreateObject("Scripting.Dictionary")
Dim name
compiler.Language = "VBScript"
compiler.AddObject "portal", portal, True
compiler.ExecuteStatement code
name = compiler.Procedures(1).Name
compiler.ExecuteStatement "portal.Add ""result"", GetRef(""Foo"") "
Set Compile = portal("result")
End Function
End Class
Dim z
Set z = New VBCompiler
Set z2 = z.Compile("Function Foo():MsgBox ""Well Met!"":Foo = 2:End Function")
z2("Hi!")
z2 "Hello Again!"
The above gives (29, 5) (null): Unspecified error. This error is in essence: your object has committed suicide.
This approach can be improved(in particular, the issue of wasteful one ScriptControl per compilation without any plans to release them).
I've got a spreadsheet that uses some basic code to get the user to select a file (txt file). It works flawlessly on Windows but fails on OSX obviously due to the difference in FileDialog calls. I've done some research though and can't seem to find much information about opening a File Dialog on both OSX and Windows for Excel/VB.
The current code is,
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to import", _
FileFilter:="Excel Files *.xls (*.xls),")
''
If FileToOpen = False Then
MsgBox "No file specified.", vbExclamation, "Duh!!!"
Exit Sub
Else
Workbooks.Open Filename:=FileToOpen
End If
Answer can be found here - http://msdn.microsoft.com/en-us/library/office/hh710200%28v=office.14%29.aspx
Code is as follows,
OSX
Sub Select_File_Or_Files_Mac()
Dim MyPath As String
Dim MyScript As String
Dim MyFiles As String
Dim MySplit As Variant
Dim N As Long
Dim Fname As String
Dim mybook As Workbook
On Error Resume Next
MyPath = MacScript("return (path to documents folder) as String")
'Or use MyPath = "Macintosh HD:Users:Ron:Desktop:TestFolder:"
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & _
" {""com.microsoft.Excel.xls""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
MyFiles = MacScript(MyScript)
On Error GoTo 0
If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MySplit = Split(MyFiles, ",")
For N = LBound(MySplit) To UBound(MySplit)
' Get the file name only and test to see if it is open.
Fname = Right(MySplit(N), Len(MySplit(N)) - InStrRev(MySplit(N), Application.PathSeparator, , 1))
If bIsBookOpen(Fname) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MySplit(N))
On Error GoTo 0
If Not mybook Is Nothing Then
MsgBox "You open this file : " & MySplit(N) & vbNewLine & _
"And after you press OK it will be closed" & vbNewLine & _
"without saving, replace this line with your own code."
mybook.Close SaveChanges:=False
End If
Else
MsgBox "We skipped this file : " & MySplit(N) & " because it Is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Windows
Sub Select_File_Or_Files_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' You can also use a fixed path.
'MyPath = "C:\Users\Ron de Bruin\Test"
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="Excel 97-2003 Files (*.xls), *.xls", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
MsgBox "You opened this file : " & Fname(N) & vbNewLine & _
"And after you press OK, it will be closed" & vbNewLine & _
"without saving. You can replace this line with your own code."
mybook.Close SaveChanges:=False
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Picker Function
Sub WINorMAC()
' Test for the operating system.
If Not Application.OperatingSystem Like "*Mac*" Then
' Is Windows.
Call Select_File_Or_Files_Windows
Else
' Is a Mac and will test if running Excel 2011 or higher.
If Val(Application.Version) > 14 Then
Call Select_File_Or_Files_Mac
End If
End If
End Sub
Sub WINorMAC_2()
' Test the conditional compiler constants.
#If Win32 Or Win64 Then
' Is Windows.
Call Select_File_Or_Files_Windows
#Else
' Is a Mac and will test if running Excel 2011 or higher.
If Val(Application.Version) > 14 Then
Call Select_File_Or_Files_Mac
End If
#End If
End Sub
I have been trying to find the answer but no exact match for my question.
below is a snippet of the script just to rename the folder, this doesn't give me a err and continue it just stops.
at the beginning of the script and general most of my script have "Option Explicit"
so I thought maybe that stopped it and I used "On Error Resume Next" but it still stops.
I know how I get the error its because I have a file open in the directory I'm trying to 'rename' what I'm attempting to do its get the script to say 'sorry you have a file open in that directory' and continue to the next folder...
Can you please help me solve this,
objFSO.MoveFolder (folder1),(folder2)
If Err.Number <> 0 Then
WScript.Echo Err.Description
WScript.Echo Err.Number
End If
Cheers,
Pav
Did you put On Error Resume Next just below the Sub? You should also Clear the Error.
I believe you are running the vbs in command prompt using cscript:
Sub RenameFolders()
On Error Resume Next
' Add your codes
objFSO.MoveFolder (folder1),(folder2)
If Err.Number <> 0 Then
WScript.Echo "sorry you have a file open in that directory"
WScript.Echo Err.Description
WScript.Echo Err.Number
Err.Clear ' Clear the ERROR!
End If
End Sub
Dim SPath 'As String
Dim DPath 'As String
SPath = "d:\test1"
DPath = "E:\test1"
Call MoveFolders(SPath ,DPath)
Sub MoveFolders(PSPath,PDPath)
'-----------------------------
PSPath = Trim(PSPath)
PDPath = Trim(PDPath)
'-----------------------------
Dim objFso 'AS Object
Dim objFil 'As Object
Dim objMFld 'As Object
Dim objSFld 'As Object
'/*----------------------------
Dim DestFullPath 'As String
Dim DestFullFilePath 'As String
'----------------------------------------------------
Set objFso = CreateObject("Scripting.FileSystemObject")
'----------------------------------------------------
If objFso.FolderExists(PSPath) Then
Set objMFld = objFso.GetFolder(PSPath)
'----------------------------------------------------
If Not objFso.FolderExists(PDPath) Then
objFso.CreateFolder(PDPath)
End If
'----------------------------------------------------
For Each objSFld In objMFld.SubFolders
DestFullPath = Replace(objSFld, PSPath, PDPath ,1, 1, vbTextCompare)
'/*------------------------
Call MoveFolders(objSFld,DestFullPath)
'/*------------------------
Next
'/*------------------------
For Each objFil In objFso.GetFolder(PSPath).Files
'/*------------------------
DestFullFilePath = PDPath & "\" & objFil.Name
'/*------------------------
If objFso.FileExists(DestFullFilePath) Then
objFSO.DeleteFile(DestFullFilePath)
End If
'/*------------------------
objFso.MoveFile objFil , PDPath & "\"
Next
'/*------------------------
If objFso.GetFolder(PSPath).Files.Count = 0 And objFso.GetFolder(PSPath).SubFolders.Count = 0 Then
objFso.DeleteFolder PSPath
End If
'------------------------------
End If
End Sub
I need some excel vba examples, where with in the VBA code(Excel Macro) i could call a VBScript and will get some values like filename and directory information from the vbscript and assign it to the variables in VBA code.
Thank you in advance
Some thing like this
VBA macro:
Sub Foo2Script
Dim x As Long
x=2
'Call VBscript here
MsgBox scriptresult
End Sub
VBScript:
Dim x, y ,Z
x = x_from_macro
y = x + 2
Z = X+Y
scriptresult = y,Z
It can be done but I would have to agree with Tomalak and others that it's not the best way to go. However, saying that, VBScript can work wonders occasionally if you use it as a kind of fire and forget mechanism. It can be used quite effectively to simulate multi-threading in VBA whereby you breakdown the payload and farm it out to individual VBScripts to run independently. Eg you could arrange a "swarm" of individual VBScripts to mass download from websites in the background whilst VBA continues with other code.
Below is some VBA code I've simplified to show what can be done and writes a simple VBScript on the fly. Normally I prefer to run it using 'wshShell.Run """" & SFilename & """" which means I can forget about it but I've included in this example this method Set proc = wshShell.exec(strexec) which allows a test of the object for completion
Put this in MODULE1
Option Explicit
Public path As String
Sub writeVBScript()
Dim s As String, SFilename As String
Dim intFileNum As Integer, wshShell As Object, proc As Object
Dim test1 As String
Dim test2 As String
test1 = "VBScriptMsg - Test1 is this variable"
test2 = "VBScriptMsg - Test2 is that variable"
'write VBScript (Writes to Excel Sheet1!A1 & Calls Function Module1.ReturnVBScript)
s = s & "Set objExcel = GetObject( , ""Excel.Application"") " & vbCrLf
s = s & "Set objWorkbook = objExcel.Workbooks(""" & ThisWorkbook.Name & """)" & vbCrLf
s = s & "Set oShell = CreateObject(""WScript.Shell"")" & vbCrLf
s = s & "Msgbox (""" & test1 & """)" & vbCrLf
s = s & "Msgbox (""" & test2 & """)" & vbCrLf
s = s & "Set oFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
s = s & "oShell.CurrentDirectory = oFSO.GetParentFolderName(Wscript.ScriptFullName)" & vbCrLf
s = s & "objWorkbook.sheets(""Sheet1"").Range(""" & "A1" & """) = oShell.CurrentDirectory" & vbCrLf
s = s & "Set objWMI = objWorkbook.Application.Run(""Module1.ReturnVBScript"", """" & oShell.CurrentDirectory & """") " & vbCrLf
s = s & "msgbox(""VBScriptMsg - "" & oShell.CurrentDirectory)" & vbCrLf
Debug.Print s
' Write VBScript file to disk
SFilename = ActiveWorkbook.path & "\TestVBScript.vbs"
intFileNum = FreeFile
Open SFilename For Output As intFileNum
Print #intFileNum, s
Close intFileNum
DoEvents
' Run VBScript file
Set wshShell = CreateObject("Wscript.Shell")
Set proc = wshShell.exec("cscript " & SFilename & "") ' run VBScript
'could also send some variable
'Set proc = wsh.Exec("cscript VBScript.vbs var1 var2") 'run VBScript passing variables
'Wait for script to end
Do While proc.Status = 0
DoEvents
Loop
MsgBox ("This is in Excel: " & Sheet1.Range("A1"))
MsgBox ("This passed from VBScript: " & path)
'wshShell.Run """" & SFilename & """"
Kill ActiveWorkbook.path & "\TestVBScript.vbs"
End Sub
Public Function ReturnVBScript(strText As String)
path = strText
End Function
This demonstrated several ways that variables can be passed around.