I have a VBS list script to list file,with various dates. All of the files are MS Word documents but I want the AUTHOR from the document attributes (I tried googling "author" attribute not the best search).
I am after a text list of all the documents in a folder :- File name , date accessed, date created, date modified and AUTHOR. I was hoping VBS would crack it but if there is another solution out there I am open to suggestions.
On Error Resume Next
Const WINDOW_HANDLE = 0
Const BIF_EDITBOX = &H10
Const BIF_NONEWFOLDER = &H0200
Const BIF_RETURNONLYFSDIRS = &H1
Set objShell = CreateObject("Shell.Application")
Set wshShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
'**Browse For Folder To Be Processed
strPrompt = "Please select the folder to process."
intOptions = BIF_RETURNONLYFSDIRS + BIF_NONEWFOLDER + BIF_EDITBOX
strTargetPath = wshShell.SpecialFolders("MyDocuments")
strFolderPath = Browse4Folder(strPrompt, intOptions, strTargetPath)
Set objNewFile = objFSO.CreateTextFile(strFolderPath & "\filelist.txt", True)
Set objFolder = objFSO.GetFolder(strFolderPath)
Set objColFiles = objFolder.Files
For Each file In objColFiles
objNewFile.WriteLine(file.Name)
objNewFile.WriteLine(file.DateCreated)
objNewFile.WriteLine(file.DateLastAccessed)
objNewFile.WriteLine(file.DateLastModified)
Next
objNewFile.Close
'**Browse4Folder Function
Function Browse4Folder(strPrompt, intOptions, strRoot)
Dim objFolder, objFolderItem
On Error Resume Next
Set objFolder = objShell.BrowseForFolder(0, strPrompt, intOptions, strRoot)
If (objFolder Is Nothing) Then
Wscript.Quit
End If
Set objFolderItem = objFolder.Self
Browse4Folder = objFolderItem.Path
Set objFolderItem = Nothing
Set objFolder = Nothing
End Function
You'll have to go through the properties of the Word Application object.
Look here for instance how to do that.
Should be something like this:
Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.Documents.Open("myWordDocument.doc")
Set sAuthor = oDoc.BuiltInDocumentProperties("Author")
Related
I'm trying to create a VBS script that will grab all the fonts from the server font location so that the domain user will have the ability to use them. When I run this script I get a line 15 char 1 error: 800A400C.
Not sure what is wrong with it or if this script will do the job I'm wanting it to do.
'On Error Resume Next
'Option Explicit
Dim objShell, objFSO, wshShell
Dim strFontSourcePath, objFolder, objFont, objNameSpace, objFile, strFontsSytem
Set objShell = CreateObject("Shell.Application")
Set wshShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FilesyStemObject")
strFontSourcePath = "\\server\Fonts\"
strFontsSytem = WSHShell.SpecialFolders("Fonts") & "\"
Set objNameSpace = objShell.Namespace(strFontSourcePath)
Set objFolder = objFSO.GetFolder(strFontSourcePath)
For Each objFile In objFolder.Files
If LCase(Right(objFile, 4)) = ".ttf" Or LCase(Right(objFile, 4)) = ".otf" Then
Set objFont = objNameSpace.ParseName(objFile.Name)
If objFSO.FileExists(strFontsSytem & objFile.Name) = False Then
objFont.InvokeVerb("Install")
Set objFont = Nothing
End If
End If
Next
Set objShell = Nothing
Set wshShell = Nothing
Set objFSO = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
WScript.Quit
Error code 800A004C means Path not found. Please check the existance of the strFontSourcePath and like Ansgar says also check if the user running this code has access to this share.
Anyway, Here's my code to copy and install fonts from a server share if that is any help
Call AddFonts("\\server\Fonts\")
WScript.Quit
Private Sub AddFonts(strFromPath)
' install fonts from a server location if not already present
Dim appShell, objShell, objFSO, colFiles, objFile, objFolder
Dim strToPath, flags, strFile, strExt
'SpecialFolder. See: https://technet.microsoft.com/en-us/library/ee176604.aspx
Const FONTFOLDER = &H14&
'CopyHere switches
Const FOF_MULTIDESTFILES = &H1&
Const FOF_CONFIRMMOUSE = &H2&
Const FOF_SILENT = &H4&
Const FOF_RENAMEONCOLLISION = &H8&
Const FOF_NOCONFIRMATION = &H10&
Const FOF_WANTMAPPINGHANDLE = &H20&
Const FOF_ALLOWUNDO = &H40&
Const FOF_FILESONLY = &H80&
Const FOF_SIMPLEPROGRESS = &H100&
Const FOF_NOCONFIRMMKDIR = &H200&
Const FOF_NOERRORUI = &H400&
Const FOF_NOCOPYSECURITYATTRIBS = &H800&
Const FOF_NORECURSION = &H1000&
Const FOF_NO_CONNECTED_ELEMENTS = &H2000&
Const FOF_WANTNUKEWARNING = &H4000&
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = Createobject("Wscript.Shell")
Set appShell = CreateObject("Shell.Application")
'create an object for the systems fonts folder
Set objFolder = appShell.Namespace(FONTFOLDER)
'make sure these paths end in a backslash
strFromPath = FixPath(strFromPath)
'get the name of the system fonts folder (C:\WINDOWS\Fonts)
strToPath = FixPath(objShell.SpecialFolders("Fonts"))
'set flags to install as quiet as possible.
flags = FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOERRORUI Or _
FOF_NOCONFIRMMKDIR Or FOF_NOCOPYSECURITYATTRIBS
If (Not objFolder Is Nothing) Then
If objFSO.FolderExists(strFromPath) Then
Set colFiles = objFSO.GetFolder(strFromPath).Files
If colFiles.Count > 0 Then
For Each objFile In colFiles
strExt = objFSO.GetExtensionName(objFile.Name)
Select Case LCase(strExt)
Case "ttf", "otf" ' can also be used for "fon", "pfm", "pfb", "afm"
'get the complete path and filename for this font file and check if already there
strFile = strToPath & objFile.Name
If Not (objFSO.FileExists(strFile)) Then
objFolder.CopyHere strFromPath & objFile.Name, flags
End If
End Select
Next
End If
End If
End If
'cleanup objects
Set appShell = Nothing
Set colFiles = Nothing
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
Set objShell = Nothing
End Sub
Private Function FixPath(sPath)
'small helper function to ensure a path ends in a backslash
If Len(sPath) > 0 And Right(sPath, 1) <> "\" Then
FixPath = sPath & "\"
Else
FixPath = sPath
End If
End Function
I am trying to open a doc file and save it as docx in batch mode. But MSWord is always shows up even when the visible attribute is set to false..
is there something wrong with my code ?
If Wscript.Arguments.Count <> 2 Then
Wscript.Echo "Wrong Arguments. Need 2 arguments; Filename and Output Directory."
Wscript.quit
End If
Dim objApp
Dim objDoc
Dim objFile
fileName = Wscript.Arguments(0)
outputDirectory = Wscript.Arguments(1)
Set objFSO = CreateObject( "Scripting.FileSystemObject" )
Set MyObject = GetObject(fileName)
if MyObject is Nothing then
objApp = CreateObject("Word.Application")
Else
Set objApp = MyObject.Application
End If
objApp.Visible = False
Set objFile = objFSO.GetFile(fileName)
Set objDoc = objApp.Documents.Open(fileName)
objDoc.SaveAs objFSO.BuildPath( outputDirectory, objFSO.GetBaseName( objFile ) & ".docx" ), 12
objDoc.Close
objApp.Quit
Set objDoc = Nothing
Set objApp = Nothing
Using the following code that I pulled from the web, I'm able to do a search in a single directory for excel files containing a string in a certain row. How would I allow this to be recursive in all the subfolders as well? I've found a few answers but I just don't understand how I would implement them in my code. I only started messing with VBScript yesterday and I'm pretty confused about how to make this work.
strComputer = "CAA-W74109188"
Set objExcel = CreateObject("Excel.Application", strComputer)
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set FileList = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_Directory.Name='c:\TDRS'} Where " _
& "ResultClass = CIM_DataFile")
For Each objFile In FileList
If (objFile.Extension = "xlsm" or objFile.Extension = "xls") Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.Name)
Set objWorksheet = objWorkbook.Worksheets(1)
If objExcel.Cells(3,10) = "Complete" or objExcel.Cells(3,9) = "Released" Then
Wscript.Echo objFile.FileName
End If
objExcel.DisplayAlerts = False
objworkbook.Saved = False
objWorkbook.Close False
End If
Next
objExcel.Quit
Here is an script that I used to delete files with, which I have modified for your needs. A recursive function is what you need to get the job done and I have always found them to be interesting and kind of hard to wrap my head around.
Dim Shell : Set Shell = WScript.CreateObject( "WScript.Shell" )
Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
Dim Paths(0)
Paths(0) = "c:\temp"
For Each Path in Paths
FolderScan(Path)
Next
Sub FolderScan(Folder)
Set base = oFSO.GetFolder(Folder)
If base.SubFolders.Count Then
For Each folder in Base.SubFolders
FolderScan(folder.Path)
Next
End If
Set files = base.Files
If files.Count Then
For Each File in files
If LCase(oFSO.GetExtensionName(File.Path) = "xlsm") or _
LCase(oFSO.GetExtensionName(File.Path) = "xls") Then
Dim objWorkbook : Set objWorkbook = objExcel.Workbooks.Open(File.Path)
Dim objWorkSheet : Set objWorkSheet = objWorkbook.Worksheets(1)
If (objExcel.Cells(3,10) = "Complete" or _
objExcel.Cells(3,9) = "Released") Then
Wscript.echo File.Path
End if
objExcel.DisplayAlerts = False
objExcel.Quit
End If
Next
End If
End Sub
Here's a generic, recursive function that iterates all files and subfolders of a given folder object.
Dim FileSystem
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder("c:\somefolder")
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
' Operate on each file
Next
End Sub
I'm trying to count the number of lines in a text file using VBScript. I have managed to do this without a problem for a text file with a fixed name. EG: "C:\Orig\sample.txt"
However, our filenames change daily, EG: "C:\Orig\sample*todaysdate*.txt"
I have looked high and low for a way to 'read' a file with a variable name and have had no luck.
What I have so far for a fixed file name is:
Dim oFso, oReg, sData, lCount, linesum
Const ForReading = 1, sPath = "C:\Orig\sample.txt"
Set oReg = New RegExp
Set oFso = CreateObject("Scripting.FileSystemObject")
sData = oFso.OpenTextFile(sPath, ForReading).ReadAll
With oReg
.Global = True
.Pattern = "\r\n" 'vbCrLf
lCount = .Execute(sData).Count + 1
End With
WScript.Echo("The total number of lines including the header is " & lCount)
Set oFso = Nothing
Set oReg = Nothing
This works perfectly well, but I just cannot find the correct syntax for a variable file name.
If it is of any help, the file I'm looking to interrogate will be the ONLY file in the containing folder.
Is anybody able to offer any assistance? Many thanks.
I have now tried the following:
Dim objFso, objReg, sData, lCount
Const ForReading = 1
sPath = "C:\Orig"
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(sPath)
For Each objFile in objFolder.Files
Set objReg = New RegExp
sData = objFso.OpenTextFile(sPath, ForReading).ReadAll
With objReg
.Global = True
.Pattern = "\r\n" 'vbCrLf
lCount = .Execute(sData).Count + 1
End With
WScript.Echo("The total number of lines including the header is " & lCount)
Set objFso = Nothing
Set objReg = Nothing
Set objFolder = Nothing
set sData = Nothing
Next
But on line 9 I am getting a 'Permission denied' error. I have checked folder permissions and file permissions and I have full rights.
Does anybody have any ideas?
Thanks in advance.
Loop through the files in the folder instead. There's no need to name the file directly.
Dim oFso, oReg, sData, lCount, linesum
Const ForReading = 1
sPath = "C:\Orig\sample\"
Set oFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder(sPath)
For Each objFile in objFolder.Files
Set oReg = New RegExp
sData = oFso.OpenTextFile(sPath, ForReading).ReadAll
With oReg
.Global = True
.Pattern = "\r\n" 'vbCrLf
lCount = .Execute(sData).Count + 1
End With
WScript.Echo("The total number of lines including the header is " & lCount)
Set oFso = Nothing
Set oReg = Nothing
Next
I need to create vbscript which will create new folder 'test' and subfolder 'Output'.There is already a folder structure C:\Documents and Settings\All Users\Application Data\Fmwire,I need to create test\Output under those structure
I have created vbscript like this but i am getting error like this
Error: Path not found
Code: 800A004C
Source: Microsoft VBScript runtime error
Const OSCPATH = "\Fmwire\test\Output"
Const ALL_USERS_APPLICATION_DATA = &H23&
Dim fso ' File System Object
Dim objApplication ' Application object
Dim objFolder ' Folder object
Dim objFolderItem ' FolderItem object
Dim fname ' Path to Settings folder
Set objApplication = CreateObject("Shell.Application")
Set objFolder = objApplication.Namespace(ALL_USERS_APPLICATION_DATA)
Set objFolderItem = objFolder.Self
fname = objFolderItem.Path & OSCPATH
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(fname) Then
Set objFolder = fso.GetFolder(fname)
Else
Set objFolder = fso.CreateFolder(fname)
If Err Then
Err.Clear
strErr = SPOFOLDERFAIL
rCode = 4
End If
End If
What changes i have to do for correcting this
Const OSCPATH = "\Fmwire\test\Output"
Const ALL_USERS_APPLICATION_DATA = &H23&
Set objApplication = CreateObject("Shell.Application")
Set objFolder = objApplication.Namespace(ALL_USERS_APPLICATION_DATA)
Set objFolderItem = objFolder.Self
fname = objFolderItem.Path
Set fso = CreateObject("Scripting.FileSystemObject")
folders = Split(OSCPATH, "\")
For i = 0 To UBound(folders)
fname = fso.BuildPath(fname, folders(i))
If fso.FolderExists(fname) Then
Set objFolder = fso.GetFolder(fname)
Else
Set objFolder = fso.CreateFolder(fname)
If Err Then
Err.Clear
strErr = SPOFOLDERFAIL
rCode = 4
End If
End If
Next