I am a newbie to VBS scripting. I am getting above error on line 54, character 5 in script below. This error says "Object doesn't support this property or method: 'MimeMapArray'".
And line it is referring to is:
MimeMapArray(i) = CreateObject("MimeMap")
Can u tell me what I am doing wrong? Here is the script in its entirety. Note, I am trying to run this on an XP OS by double-clicking this VBS file.
' This script adds the necessary Windows Presentation Foundation MIME types
' to an IIS Server.
' To use this script, just double-click or execute it from a command line.
' Running this script multiple times results in multiple entries in the IIS MimeMap.
' Set the MIME types to be added
Dim MimeMapObj
Dim MimeMapArray
Dim WshShell
Dim oExec
Const ADS_PROPERTY_UPDATE = 2
Dim MimeTypesToAddArray
MimeTypesToAddArray = Array(".manifest", "application/manifest", ".xaml", _
"application/xaml+xml", ".application", "application/x-ms-application", _
".deploy", "application/octet-stream", ".xbap", "application/x-ms-xbap", _
".xps", "application/vnd.ms-xpsdocument")
' Get the mimemap object
Set MimeMapObj = GetObject("IIS://LocalHost/MimeMap")
' Call AddMimeType for every pair of extension/MIME type
For counter = 0 to UBound(MimeTypesToAddArray) Step 2
AddMimeType MimeTypesToAddArray(counter), MimeTypesToAddArray(counter+1)
Next
' Create a Shell object
Set WshShell = CreateObject("WScript.Shell")
' Stop and Start the IIS Service
Set oExec = WshShell.Exec("net stop w3svc")
Do While oExec.Status = 0
WScript.Sleep 100
Loop
Set oExec = WshShell.Exec("net start w3svc")
Do While oExec.Status = 0
WScript.Sleep 100
Loop
Set oExec = Nothing
' Report status to user
WScript.Echo "Windows Presentation Foundation MIME types have been registered."
' AddMimeType Sub
Sub AddMimeType(ByVal Ext, ByVal MType)
' Get the mappings from the MimeMap property.
MimeMapArray = MimeMapObj.GetEx("MimeMap")
' Add a new mapping.
i = UBound(MimeMapArray) + 1
ReDim Preserve MimeMapArray(i)
MimeMapArray(i) = CreateObject("MimeMap")
MimeMapArray(i).Extension = Ext
MimeMapArray(i).MimeType = MType
MimeMapObj.PutEx ADS_PROPERTY_UPDATE, "MimeMap", MimeMapArray
MimeMapObj.SetInfo()
End Sub
The first thing I can suggest is use cscript to execute. You can get more information that won't go away like with a message box.
Open a command prompt (go to start,
run, type CMD).
Go to the location where your script
is and type the following:
cscript scriptname.vbs
...where scriptname.vbs is the name of your script.
Second, you appear to be missing the "set" in front of your createobject line. Have a look here for reference.
That line should look like:
set MimeMapArray(i) = CreateObject("MimeMap")
Related
I'm trying to write a script for a while now but it seems that one part of it just does not work.
Situation: I need a VB script that can use any LibreOffice (/ OpenOffice) Calc (3.5.4 in my case) installation on any Windows XP or 7 system for export of xls to csv (as many csv files as there are sheets in the xls). It has to be VBS and LibreOffice in this case. No macro installed, everything controlled externally by vbscript.
So, first step was to use the macro recorder in order to get the right filter settings.
StarBasic macro:
dim document as object
dim dispatcher as object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
dim args1(2) as new com.sun.star.beans.PropertyValue
args1(0).Name = "URL"
args1(0).Value = "file:///C:/Users/lutz/Desktop/test.csv"
args1(1).Name = "FilterName"
args1(1).Value = "Text - txt - csv (StarCalc)"
args1(2).Name = "FilterOptions"
args1(2).Value = "9,0,76,1,,0,false,true,true"
dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1())
This macro (in LibreOffice) writes a CSV of the current sheet (after LO telling me that only the current sheet will be saved), encoding UTF-8, field separator Tab, no text separator. This works.
I tried to get this to work in my vbs but it absolutely did not. So I searched a lot in OpenOffice and LibreOffice forums, here at stackoverflow, etc. and used another method.
Problem: Everytime it saves the file(s) it saves them as ODS, no matter which filter or filter options I use. It always saves to zipped OpenDocument. I tried numerous Filters, even PDF. It seems that it works with pdf when I only use the FilterName property but somehow it doesn't work anymore. And I don't know why.
The code:
' Scripting object
Dim wshshell
' File system object
Dim objFSO
' OpenOffice / LibreOffice Service Manager
Dim objServiceManager
' OpenOffice / LibreOffice Desktop
Dim objDesktop
' Runcommand, if script does not run with Cscript
Dim runcommand
Dim Path
Dim Savepath
Dim Filename
Dim url
Dim args0(0)
Dim args1(3)
' Create File system object
Set wshshell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If files present, run Calc
If objFSO.GetFolder(".").Files.Count>0 then
Set objServiceManager = WScript.CreateObject("com.sun.star.ServiceManager")
' Create Desktop
Set objDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
else
' If no files in directory
wscript.echo "No files found!"
wscript.quit
End If
on error resume next
bError=False
For each File in objFSO.GetFolder(".").Files
if lcase(right(File.Name,3))="xls" then
' Access file
url = ConvertToURL(File.Path)
objDesktop = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
Set args0(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set objDocument = objDesktop.loadComponentFromURL(url, "_blank", 0, args0 )
' Read filenames without extension or path
Path = ConvertToURL( File.ParentFolder ) & "/"
Filename = objFSO.GetBaseName( File.Path )
Savepath = ConvertToURL( File.ParentFolder )
' set arguments
Set args1(0) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(1) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args1(2) = objServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
Set args1(0) = MakePropertyValue( "FilterName", sFilterName )
Set args1(1) = MakePropertyValue( "FilterOptions", sFilterOptions )
Set args1(2) = MakePropertyValue( "Overwrite", sOverwrite )
' Save every sheet in separate csv file
objSheets = objDocument.Sheets
For i = 0 to objDocument.Sheets.getcount -1
objSheet = objDocument.Sheets.getByIndex(i)
Call objDocument.CurrentController.setActiveSheet(objSheet)
Call objDocument.storeToURL( ConvertToURL( File.ParentFolder & "\" & Filename & "_" & objDocument.sheets.getByIndex(i).Name & ".csv" ), args1 )
Next
' Close document
objDocument.close(True)
Set objDocument = Nothing
Path = ""
Savepath = ""
Filename = ""
Else
End If
Next
' Close / terminate LibreOffice
objDesktop.terminate
Set objDesktop = nothing
Set objServiceManager = nothing
The function ConvertToUrl is not listed here. It is a vbscript function that converts Windows paths to URL paths (file:/// etc.). It is tested and works.
What I also tried:
Saving in ods first (StoreAsUrl) then try to save in different format.
Use MakePropertyValue( "SelectionOnly", true )
None of that worked nor did it combined. I used http://extensions.services.openoffice.org/de/project/OOcalc_multi_sheets_export as a source of inspiration. But it is a macro, not direct access from an external vb script.
It seems that the problem is a general one with StoreToUrl or the properties / arguments:
Even FilterName "writer_pdf" or "Calc MS Excel 2007 XML" don't work. Problem is: I don't know what's the culprit here. The settings that the macro recorder uses are the same and if one uses the macro directly in LibreOffice it works.
Maybe someone knows what needs to get changed in the code or how I can get the dispatcher used in the macro to work.
Thank you for your help in advance!
Ok, I found the solution after days of research and tiny little information scattered everywhere. I hope that this code will serve someone well:
' Variables
Dim wshshell ' Scripting object
Dim oFSO ' Filesystem object
Dim runcommand ' Runcommand, if not run in Cscript
Dim oSM ' OpenOffice / LibreOffice Service Manager
Dim oDesk ' OpenOffice / LibreOffice Desktop
Dim oCRef ' OpenOffice / LibreOffice Core Reflections
Dim sFileName ' Filename without extension
Dim sLoadUrl ' Url for file loading
Dim sSaveUrl ' Url for file writing
Dim args0(0) ' Load arguments
' Create file system object
Set wshshell = CreateObject("Wscript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
' If not run in cscript, run in cscript
if instr(1, wscript.fullname, "cscript.exe")=0 then
runcommand = "cscript //Nologo xyz.vbs"
wshshell.run runcommand, 1, true
wscript.quit
end if
' If there are files, start Calc
If oFSO.GetFolder(".").Files.Count>0 then
' If no LibreOffice open -> run
Set oSM = WScript.CreateObject("com.sun.star.ServiceManager")
' Create desktop
Set oDesk = oSM.createInstance("com.sun.star.frame.Desktop")
Set oCRef = oSM.createInstance( "com.sun.star.reflection.CoreReflection" )
else
' If no files in directory
wscript.quit
End If
' Error handling
on error resume next
' CSV settings for saving of file(s)
sFilterName = "Text - txt - csv (StarCalc)"
sFilterOptions = "9,0,76,1,,0,false,true,true"
sOverwrite = True
' load component for file access
oDesk = GlobalScope.BasicLibraries.loadLIbrary( "Tools" )
' load argument "hidden"
Set args0(0) = oSM.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
Set args0(0) = MakePropertyValue("Hidden", True)
For each oFile in oFSO.GetFolder(".").Files
if lcase(right(oFile.Name,3))="xls" then
' open file
sLoadUrl = ConvertToURL(oFile.Path)
Set oDoc = oDesk.loadComponentFromURL(sLoadUrl, "_blank", 0, args0 )
' read filename without extension or path
sFileName = oFSO.GetBaseName( oFile.Path )
' save sheets in CSVs
For i = 0 to oDoc.Sheets.getcount -1
oActSheet = oDoc.CurrentController.setActiveSheet( oDoc.Sheets.getByIndex(i) )
sSaveUrl = ConvertToURL( oFile.ParentFolder & "\" & sFileName & "_" & oDoc.sheets.getByIndex(i).Name & ".csv" )
saveCSV oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite
Next
' Close document
oDoc.close(True)
Set oDoc = Nothing
Set oActSheet = Nothing
sFileName = ""
sLoadUrl = ""
sSaveUrl = ""
Else
End If
Next
' Close LibreOffice
oDesk.terminate
Set oDesk = nothing
Set oSM = nothing
Function ConvertToURL(sFileName)
' Convert Windows pathnames to url
Dim sTmpFile
If Left(sFileName, 7) = "file://" Then
ConvertToURL = sFileName
Exit Function
End If
ConvertToURL = "file:///"
sTmpFile = oFSO.GetAbsolutePathName(sFileName)
' replace any "\" by "/"
sTmpFile = Replace(sTmpFile,"\","/")
' replace any "%" by "%25"
sTmpFile = Replace(sTmpFile,"%","%25")
' replace any " " by "%20"
sTmpFile = Replace(sTmpFile," ","%20")
ConvertToURL = ConvertToURL & sTmpFile
End Function
Function saveCSV( oSM, oDoc, sSaveUrl, sFilterName, sFilterOptions, sOverwrite )
' Saves the open document resp. active sheet in a single file
Dim aProps( 2 ), oProp0, oProp1, oProp2, vRet
' Set filter name and write into property array
Set oProp0 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp0.Name = "FilterName"
oProp0.Value = sFilterName
Set aProps( 0 ) = oProp0
' Set filter options and write into property array
Set oProp1 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp1.Name = "FilterOptions"
oProp1.Value = sFilterOptions
Set aProps( 1 ) = oProp1
' Set file overwrite and write into property array
Set oProp2 = oSM.Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oProp2.Name = "Overwrite"
oProp2.Value = sOverwrite
Set aProps( 2 ) = oProp2
' Save
vRet = oDoc.storeToURL( sSaveUrl, aProps )
End Function
I hope that at least this small contribution from me helps others.
I am attempting to close a shell Chrome window via a VBA function. My function runs a URL query that returns a .csv file. The thing is I would like to close the window so that it is not always showing (This process runs every 3 minutes). I haven't been able to find a solution that I can get to work as of yet. I tried adding SendKeys "%{F4}" after as one site suggested. This merely minimizes the window, not close it. I also attempted to try adding DoCmd.Close Shell, "Untitled" after, yet this also did not work. I have spent several hours attempting to do, what I imagine is a simple task, and felt another set of eyes could point me in the right direction. Below is my code that opens Chrome. Any assistance is greatly appreciated.
Public Function RunYahooAPI()
Dim chromePath As String
chromePath = """C:\Program Files\Google\Chrome\Application\chrome.exe"""
Shell (chromePath & " -url http://download.finance.yahoo.com/d/quotes.csv?s=CVX%2CXOM%2CHP%2CSLB%2CPBA%2CATR%2CECL%2CNVZMY%2CMON&f=nsl1op&e=.csv")
End Function
this VBA code will launch (as in your question) chrome, save the Process handle in the variable pHandle, loop all processes with this Handle and then stop the process (after checking user and domain of the process owner) .
Sub LaunchandStopProcess()
'
' As in your Question
'
Dim chromePath As String
Dim pHandle As Variant
chromePath = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
'
' Note: Shell pass the Process Handle to the PID variable
'
PHandle = Shell(chromePath & " -url http://download.finance.yahoo.com/d/quotes.csv?s=CVX%2CXOM%2CHP%2CSLB%2CPBA%2CATR%2CECL%2CNVZMY%2CMON&f=nsl1op&e=.csv")
Dim objWMIcimv2 As Object
Dim objProcess As Object
Dim objList As Object
Dim ProcToTerminate As String
Dim intError As Integer
Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where Handle='" & CStr(pHandle) & "'")
'
' ObjList contains the list of all process matching the Handle (normally your chrome App, if running)
'
If objList.Count = 0 Then
' No matching Process
' Set all objects to nothing
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Exit Sub
Else
'
' Parse all matching Processes
'
For Each objProcess In objList
' additionally check with actual user
colProperties = objProcess.getowner(strNameofUser, strUserdomain)
If strUserdomain + "\" + strNameofUser = Environ$("userdomain") + "\" + Environ$("username") Then
intError = objProcess.Terminate
If intError <> 0 Then
'
' Trap Error or do nothing if code run unattended
'
Else
' Confirm that process is killed or nothing if code run unattended
End If
End If
Next
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
End If
End Sub
I am changing product code, upgrade code and product name of MSI by editing MSI database.
With reference :- http://www.codeproject.com/Articles/383481/Editing-an-MSI-Database
I am able to change all parameters above but unable to change Package Code.
Suggest a way to change package code.
Found a way to do it with vbscript, just out of curiosity:
The "property #9" is the package code (revision number).
Set wi = CreateObject("WindowsInstaller.Installer")
Set summary = wi.SummaryInformation("your.msi", 2)
summary.Property(9) = "{PUT-NEW-GUID-HERE}"
summary.Persist
I'm guessing that the requirement here is to install the same MSI multiple times, which means they need to change that set of guids. However the more normal way to solve that problem is with MSINEWINSTANCE.
https://msdn.microsoft.com/en-us/library/aa370326(v=vs.85).aspx
https://msdn.microsoft.com/en-us/library/aa369528(v=vs.85).aspx
so that you are not changing the base MSI file every time.
Why do you even have the need to set the package code?
Its auto generated during each build.
Take a look at the documentation of the Package element:
http://wixtoolset.org/documentation/manual/v3/xsd/wix/package.html
"The package code GUID for a product or merge module. When compiling a product, this attribute should not be set in order to allow the package code to be generated for each build. When compiling a merge module, this attribute must be set to the modularization guid."
I needed it because MSI created cache in respective package code which restricts us to make another instance of application using MSI so I did this by
using (var database = new Database(#"D:\\Nirvana\\WorkingCopy\\trunk\\proj1\\installer.msi", DatabaseOpenMode.Direct))
{
database.SummaryInfo.RevisionNumber = "{" + Guid.NewGuid() + "}";
}
I extended the Nikolay script for generating a random GUID automatically. The script also support drag and drop and be called through arguments (so you can easily automate it through cscript) and it checks if the file is writable before creating Windows Installer object (if the file is locked by some application, like InstEd, it will throw an error).
Set objArgs = Wscript.Arguments
Set objFso = CreateObject("scripting.filesystemobject")
'iterate through all the arguments passed
' https://community.spiceworks.com/scripts/show/1653-drag-drop-vbscript-framework
For i = 0 to objArgs.count
on error resume next
'try and treat the argument like a folder
Set folder = objFso.GetFolder(objArgs(i))
'if we get an error, we know it is a file
If err.number <> 0 then
'this is not a folder, treat as file
ProcessFile(objArgs(i))
Else
'No error? This is a folder, process accordingly
For Each file In folder.Files
ProcessFile(file)
Next
End if
On Error Goto 0
Next
Function ProcessFile(sFilePath)
' http://www.wisesoft.co.uk/scripts/vbscript_file_modified_date.aspx
' Set objFile = objFSO.GetFile(sFilePath)
' MsgBox "Now processing file: " & CDATE( objFile.DateLastModified)
If Not IsWriteAccessible(sFilePath) Then WScript.Echo "Error persisting summary property stream" : Wscript.Quit 2
'Do something with the file here...
' https://stackoverflow.com/questions/31536349/set-package-code-of-msi-using-vbscript
Set installer = CreateObject("WindowsInstaller.Installer")
Set summary = installer.SummaryInformation(sFilePath, 2)
summary.Property(9) = CreateGuid()
summary.Persist
End Function
' https://stackoverflow.com/questions/968756/how-to-generate-a-guid-in-vbscript
Function CreateGuid()
CreateGuid = Left(CreateObject("Scriptlet.TypeLib").Guid,38)
End Function
' https://stackoverflow.com/questions/12300678/how-can-i-determine-if-a-file-is-locked-using-vbs
Function IsWriteAccessible(sFilePath)
' Strategy: Attempt to open the specified file in 'append' mode.
' Does not appear to change the 'modified' date on the file.
' Works with binary files as well as text files.
' Only 'ForAppending' is needed here. Define these constants
' outside of this function if you need them elsewhere in
' your source file.
Const ForReading = 1, ForWriting = 2, ForAppending = 8
IsWriteAccessible = False
Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Dim nErr : nErr = 0
Dim sDesc : sDesc = ""
Dim oFile : Set oFile = oFso.OpenTextFile(sFilePath, ForAppending)
If Err.Number = 0 Then
oFile.Close
If Err Then
nErr = Err.Number
sDesc = Err.Description
Else
IsWriteAccessible = True
End if
Else
Select Case Err.Number
Case 70
' Permission denied because:
' - file is open by another process
' - read-only bit is set on file, *or*
' - NTFS Access Control List settings (ACLs) on file
' prevents access
Case Else
' 52 - Bad file name or number
' 53 - File not found
' 76 - Path not found
nErr = Err.Number
sDesc = Err.Description
End Select
End If
' The following two statements are superfluous. The VB6 garbage
' collector will free 'oFile' and 'oFso' when this function completes
' and they go out of scope. See Eric Lippert's article for more:
' http://blogs.msdn.com/b/ericlippert/archive/2004/04/28/when-are-you-required-to-set-objects-to-nothing.aspx
'Set oFile = Nothing
'Set oFso = Nothing
On Error GoTo 0
If nErr Then
Err.Raise nErr, , sDesc
End If
End Function
I am writing a VB Script to update some files on the network. Before beginning, I want to know if any of the files are locked. I'd like to do this before I actually do any updates.
I am aware that I can handle the error if the file is locked when I try to replace it, but I really want to know if any files are locked before I start updating any files.
Is there any way to see that a file is locked using VBS (apart from trying to replace it)?
This function determines whether a file of interest can be accessed in 'write' mode. This is not exactly the same as determining whether a file is locked by a process. Still, you may find that it works for your situation. (At least until something better comes along.)
This function will indicate that 'write' access is not possible when a file is locked by another process. However, it cannot distinguish that condition from other conditions that prevent 'write' access. For instance, 'write' access is also not possible if a file has its read-only bit set or possesses restrictive NTFS permissions. All of these conditions will result in 'permission denied' when a 'write' access attempt is made.
Also note that if a file is locked by another process, the answer returned by this function is reliable only at the moment the function is executed. So, concurrency problems are possible.
An exception is thrown if any of these conditions are found: 'file not found', 'path not found', or 'illegal file name' ('bad file name or number').
Function IsWriteAccessible(sFilePath)
' Strategy: Attempt to open the specified file in 'append' mode.
' Does not appear to change the 'modified' date on the file.
' Works with binary files as well as text files.
' Only 'ForAppending' is needed here. Define these constants
' outside of this function if you need them elsewhere in
' your source file.
Const ForReading = 1, ForWriting = 2, ForAppending = 8
IsWriteAccessible = False
Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Dim nErr : nErr = 0
Dim sDesc : sDesc = ""
Dim oFile : Set oFile = oFso.OpenTextFile(sFilePath, ForAppending)
If Err.Number = 0 Then
oFile.Close
If Err Then
nErr = Err.Number
sDesc = Err.Description
Else
IsWriteAccessible = True
End if
Else
Select Case Err.Number
Case 70
' Permission denied because:
' - file is open by another process
' - read-only bit is set on file, *or*
' - NTFS Access Control List settings (ACLs) on file
' prevents access
Case Else
' 52 - Bad file name or number
' 53 - File not found
' 76 - Path not found
nErr = Err.Number
sDesc = Err.Description
End Select
End If
' The following two statements are superfluous. The VB6 garbage
' collector will free 'oFile' and 'oFso' when this function completes
' and they go out of scope. See Eric Lippert's article for more:
' http://blogs.msdn.com/b/ericlippert/archive/2004/04/28/when-are-you-required-to-set-objects-to-nothing.aspx
'Set oFile = Nothing
'Set oFso = Nothing
On Error GoTo 0
If nErr Then
Err.Raise nErr, , sDesc
End If
End Function
The script below tries to write to a file for 30 seconds and gives up after that. I needed this when all our users had to click on a script. Chances are that multiple users try to write at the same time. OpenCSV() tries to open the file 30 times with a delay of 1 second in between.
Const ForAppending = 8
currentDate = Year(Now) & "-" & Month(Now) & "-" & Day(Now) & " " & Hour(Now) & ":" & Minute(Now) & ":" & Second(Now)
filepath = "\\network\path\file.csv"
Set oCSV = OpenCSV( filepath )
oCSV.WriteLine( currentDate )
oCSV.Close
Function OpenCSV( path )
Set oFS = CreateObject( "Scripting.FileSystemObject" )
For i = 0 To 30
On Error Resume Next
Set oFile = oFS.OpenTextFile( path, ForAppending, True )
If Not Err.Number = 70 Then
Set OpenCSV = oFile
Exit For
End If
On Error Goto 0
Wscript.Sleep 1000
Next
Set oFS = Nothing
Set oFile = Nothing
If Err.Number = 70 Then
MsgBox "File " & filepath & " is locked and timeout was exceeded.", vbCritical
WScript.Quit
End If
End Function
Or, more simply:
Assuming you already have a variable in your VBS named FileName, which contains the full filepath you want to test:
Dim oFso, oFile
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oFile = oFso.OpenTextFile(FileName, 8, True)
If Err.Number = 0 Then oFile.Close
Line 3 tries to open the file you want to test with append permissions enabled. e.g. it attempts to open the file with a write lock.
If opening the file with a write lock generates an error, then your VBS will error on the third line and not continue. At that point your error handling from wherever you called the VBS should kick in. The error message will be "Permission Denied" if you couldn't get a write lock.
If opening the file with a lock doesn't result in an error, then line 4 closes it again. You can now open the file or do whatever you want with it, confident that it doesn't have a write lock on it.
I am looking for a method to place some text onto the clipboard with VBScript. The VBScript in question will be deployed as part of our login script. I would like to avoid using anything that isn't available on a clean Windows XP system.
Edit:
In answer to the questions about what this is for.
We wanted to encourage users inside our organization to use the file server to transfer documents instead of constantly sending attachments by email. One of the biggest barriers to this is that it isn't always obvious to people what the correct network path is to a file/folder. We developed a quick script, and attached it to the Windows context menu so that a user can right click on any file/folder, and get a URL that they can email to someone within our organization.
I want the URL displayed in the dialog box to also be placed onto the clipboard.
GetNetworkPath
Another solution I have found that isn't perfect in my opinion, but doesn't have the annoying security warnings is to use clip.exe from a w2k3 server.
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run "cmd.exe /c echo hello world | clip", 0, TRUE
Example with a multiline string as per question below :
Link1
Dim string
String = "text here" &chr(13)& "more text here"
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run "cmd.exe /c echo " & String & " | clip", 0, TRUE
Using Microsoft's clip.exe is the closest to having a clean Windows XP system solution. However you don't have to call CMD.EXE to host it in order to use it. You can call it directly and write to its input stream in your script code. Once you close the input stream clip.exe will write the contents straight to the clipboard.
Set WshShell = CreateObject("WScript.Shell")
Set oExec = WshShell.Exec("clip")
Set oIn = oExec.stdIn
oIn.WriteLine "Something One"
oIn.WriteLine "Something Two"
oIn.WriteLine "Something Three"
oIn.Close
If you need to wait for clip to be finished before your script can continue processing then add
' loop until we're finished working.
Do While oExec.Status = 0
WScript.Sleep 100
Loop
And don't forget to release your objects
Set oIn = Nothing
Set oExec = Nothing
The closest solution I have found so far is a method to use IE to get and set stuff on the clipboard. The problem with this solution is the user gets security warnings. I am tempted to move 'about:blank' to the local computer security zone so I don't get the warnings, but I am not sure what the security implications of that would be.
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate("about:blank")
objIE.document.parentwindow.clipboardData.SetData "text", "Hello This Is A Test"
objIE.Quit
http://www.microsoft.com/technet/scriptcenter/resources/qanda/dec04/hey1215.mspx
No security warnings, full let and get access:
'create a clipboard thing
Dim ClipBoard
Set Clipboard = New cClipBoard
ClipBoard.Clear
ClipBoard.Data = "Test"
Class cClipBoard
Private objHTML
Private Sub Class_Initialize
Set objHTML = CreateObject("htmlfile")
End Sub
Public Sub Clear()
objHTML.ParentWindow.ClipboardData.ClearData()
End Sub
Public Property Let Data(Value)
objHTML.ParentWindow.ClipboardData.SetData "Text" , Value
End Property
Public Property Get Data()
Data = objHTML.ParentWindow.ClipboardData.GetData("Text")
End Property
Private Sub Class_Terminate
Set objHTML = Nothing
End Sub
End Class
Example Usage.
' Create scripting object
Dim WShell, lRunUninstall
Set WShell = CreateObject("WScript.Shell")
WShell.sendkeys "^c"
WScript.Sleep 250
bWindowFound = WShell.AppActivate("Microsoft Excel")
WShell.sendkeys ClipBoard.Data
To avoid the security warnings associated with Internet Explorer and clipboard access, I would recommend you use the Word application object and its methods to put your data onto the clipboard. Of course you can only use this on a machine that has MS Word installed, but these days that's most of them. (*In spite of the fact that you asked for stuff on a 'clean' system :) *)
' Set what you want to put in the clipboard '
strMessage = "Imagine that, it works!"
' Declare an object for the word application '
Set objWord = CreateObject("Word.Application")
' Using the object '
With objWord
.Visible = False ' Don't show word '
.Documents.Add ' Create a document '
.Selection.TypeText strMessage ' Put text into it '
.Selection.WholeStory ' Select everything in the doc '
.Selection.Copy ' Copy contents to clipboard '
.Quit False ' Close Word, don't save '
End With
You can find detail on the MS Word application object and its methods here: http://msdn.microsoft.com/en-us/library/aa221371(office.11).aspx
Microsoft doesn't give a way for VBScript to directly access the clipboard. If you do a search for 'clipboard'on this site you'll see:
Although Visual Basic for Applications supports the Screen, Printer, App, Debug, Err, and Clipboard objects, VBScript supports only the Err object. Therefore, VBScript does not allow you to access such useful objects as the mouse pointer or the clipboard. You can, however, use the Err object to provide runtime error handling for your applications.
So using notepad indirectly is probably about the best you'll be able to do with just VBScript.
Here's another version of using the "clip" command, which avoids adding a carriage return, line feed to the end of the string:
strA= "some character string"
Set objShell = WScript.CreateObject("WScript.Shell")
objShell.Run "cmd /C echo . | set /p x=" & strA & "| c:\clip.exe", 2
s = "String: """ & strA & """ is on the clipboard."
Wscript.Echo s
I've only tested this in XP. clip.exe was downloaded from Link and placed in C:\.
I've found a way to copy multi line information to clipboard by vbscript/cmd.
Sequence:
with VBS generate the final "formatted string" that you need copy to clipboard
generate a (txt) file with the "formatted string"
use type command from cmd to paste information to clip by pipe
Example script:
Function CopyToClipboard( sInputString )
Dim oShell: Set oShell = CreateObject("WScript.Shell")
Dim sTempFolder: sTempFolder = oShell.ExpandEnvironmentStrings("%TEMP%")
Dim sFullFilePath: sFullFilePath = sTempFolder & "\" & "temp_file.txt"
Const iForWriting = 2, bCreateFile = True
Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO.OpenTextFile(sFullFilePath, iForWriting, bCreateFile)
.Write sInputString
.Close
End With
Const iHideWindow = 0, bWaitOnReturnTrue = True
Dim sCommand: sCommand = "CMD /C TYPE " & sFullFilePath & "|CLIP"
oShell.Run sCommand, iHideWindow, bWaitOnReturnTrue
Set oShell = Nothing
Set oFSO = Nothing
End Function
Sub Main
Call CopyToClipboard( "Text1" & vbNewLine & "Text2" )
End Sub
Call Main
The easiest way is to use built-in mshta.exe functionality:
sText = "Text Content"
CreateObject("WScript.Shell").Run "mshta.exe ""javascript:clipboardData.setData('text','" & Replace(Replace(sText, "\", "\\"), "'", "\'") & "');close();""", 0, True
To put to clipboard a string containing double quote char ", use the below code:
sText = "Text Content and double quote "" char"
CreateObject("WScript.Shell").Run "mshta.exe ""javascript:clipboardData.setData('text','" & Replace(Replace(Replace(sText, "\", "\\"), """", """"""), "'", "\'") & "'.replace('""""',String.fromCharCode(34)));close();""", 0, True
Take a look at this post. It describes a hacky approach to read from the clipboard, but I imagine it could be adapted to also write to the clipboard as well, such as changing the Ctrl+V to Ctrl+A then Ctrl+C.
I devised another way to use IE and yet avoid security warnings...
By the way.. this function is in JavaScript.. but u can easily convert it to VBScript..
function CopyText(sTxt) {
var oIe = WScript.CreateObject('InternetExplorer.Application');
oIe.silent = true;
oIe.Navigate('about:blank');
while(oIe.ReadyState!=4) WScript.Sleep(20);
while(oIe.document.readyState!='complete') WSript.Sleep(20);
oIe.document.body.innerHTML = "<textarea id=txtArea wrap=off></textarea>";
var oTb = oIe.document.getElementById('txtArea');
oTb.value = sTxt;
oTb.select();
oTb = null;
oIe.ExecWB(12,0);
oIe.Quit();
oIe = null;
}
Here is Srikanth's method translated into vbs
function SetClipBoard(sTxt)
Set oIe = WScript.CreateObject("InternetExplorer.Application")
oIe.silent = true
oIe.Navigate("about:blank")
do while oIe.ReadyState <> 4
WScript.Sleep 20
loop
do while oIe.document.readyState <> "complete"
WScript.Sleep 20
loop
oIe.document.body.innerHTML = "<textarea id=txtArea wrap=off></textarea>"
set oTb = oIe.document.getElementById("txtArea")
oTb.value = sTxt
oTb.select
set oTb = nothing
oIe.ExecWB 12,0
oIe.Quit
Set oIe = nothing
End function
function GetClipBoard()
set oIe = WScript.CreateObject("InternetExplorer.Application")
oIe.silent = true
oIe.Navigate("about:blank")
do while oIe.ReadyState <> 4
WScript.Sleep 20
loop
do while oIe.document.readyState <> "complete"
WScript.Sleep 20
loop
oIe.document.body.innerHTML = "<textarea id=txtArea wrap=off></textarea>"
set oTb = oIe.document.getElementById("txtArea")
oTb.focus
oIe.ExecWB 13,0
GetClipBoard = oTb.value
oTb.select
set oTb = nothing
oIe.Quit
Set oIe = nothing
End function
In your Class ClipBoard, neither the Clear sub nor the Let Data sub work. I mean they have no effect on Windows Clipboard. Actually, and ironically so, the only sub that works is the one you have not included in your example, that is Get Data! (I have tested this code quite a few times.)
However, it's not your fault. I have tried to copy data to clipboard with ClipboardData.SetData and it's impossible. At least not by creating an "htmlfile" object. Maybe it works by creating an instance of "InternetExplorer.Application" as I have seen in a few cases, but I have not tried it. I hate creating application instances for such simple tasks!
Alkis
If it's just text can't you simply create a text file and read in the contents when you need it?
Another alternative and clearly a kludge, would be to use the SendKeys() method.
No security warnings and no carriage return at the end of line
' value to put in Clipboard
mavaleur = "YEAH"
' current Dir
path = WScript.ScriptFullName
GetPath = Left(path, InStrRev(path, "\"))
' Put the value in a file
Set objFSO=CreateObject("Scripting.FileSystemObject")
outFile=GetPath & "fichier.valeur"
Set objFile = objFSO.CreateTextFile(outFile,True)
objFile.Write mavaleur
objFile.Close
' Put the file in the Clipboard
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Run "cmd.exe /c clip < " & outFile, 0, TRUE
' Erase the file
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFile outFile