Being I'm a novice at VBS, I'm have a hard time determining why this short script is not returning a column count of 193, One time I'll get the correct count and others I get 0.
Thank you in advance for any and all suggestions.
OldCityCat
Sub VerifyOrders
Dim Results
Dim objFSO, objTextFile, objReadFile, Contents, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile("C:\TestFileWith_194_characters.csv")
Set objTextFile = objFSO.OpenTextFile("C:\TestFileWith_194_characters.csv")
Set objReadFile = objFSO.OpenTextFile("C:\TestFileWith_194_characters.csv",1)
objReadFile.ReadAll
Contents = objReadFile.Column -1
WScript.Echo Contents
If Contents < 194 Then
Results = "No Orders"
Else
Results = "Has Orders"
End if
objReadFile.Close
If Results = "No Orders" Then
Call NoOrders
Else
Call OpenAccess
End If
End Sub
'/ If no orders the send email end script. Else If orders process them
Sub NoOrders
If Results = "No Orders" Then
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
objMail.Display
objMail.Recipients.Add ("gchichester#wilk.us.com")
objMail.Subject = "No Sales Orders to Process"
objMail.Body = "Respect didn't receive any orders for Pine Castle"
objMail.Send
objOutlook.Quit
Set objMail = Nothing
Set objOutlook = Nothing
End If
End Sub
Sub OpenAccess
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.Exec("C:\Program Files (x86)\Microsoft Office\Office14\MSACCESS.EXE "&" C:\DropBox\Inflow\DrugSales.accdb /x OnOpen")
WScript.Sleep 60000
WshShell.SendKeys "%{F4}"
End Sub
You are getting 0 when the contents of the text file you're reading from has written a newline character, but nothing else.
From the Microsoft documentation:
After a newline character has been written, but before any other character is written, Column is equal to 1.
Throughly examine the contents of the text file before you attempt to read it in as a text stream.
Of note but not relevant to my answer above: you do not need to declare or set objFile or objTextFile since you are using objReadFile. Suggest removing both the declaration and set operations for both of those variables.
Related
How to print the page numbers which has changes after comparing the word documents.
I have written the following code to find the differences using vb script. Kindly help in identify and print the page numbers.
> Declaring FSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFile("C:\Users\amunaga\Desktop\POC doc comparision\POC\DocumentsWithChanges\*.docx")
'Getting absolute path
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim CurrentDirectory
CurrentDirectory = objFSO.GetAbsolutePathName(".")
Set objExcel = createobject("Excel.Application")
Set objWorkBook = objExcel.Workbooks.open("C:\Users\amunaga\Desktop\POC doc comparision\POC\Report.xlsx")
Set objSheet= objWorkBook.Worksheets("Sheet1")
Set objRange = objSheet.UsedRange
RowsCount = objRange.Rows.Count
For Iterator = 2 To RowsCount
BaseDocName= objSheet.Cells(Iterator,2).Value
NewDocName = objSheet.Cells(Iterator,3).Value
strBaseDoc = "C:\Users\amunaga\Desktop\POC doc comparision\POC\BaseDocuments\"&BaseDocName&".docx"
strNewDoc = "C:\Users\amunaga\Desktop\POC doc comparision\POC\NewDocuments\"&NewDocName&".docx"
fContinue = True
fContinue = objFSO.FileExists(strBaseDoc)
fContinue = objFSO.FileExists(strNewDoc)
If fContinue = False Then
MsgBox "Invalid File Paths" ,vbExclamation ,"Error"
Else
Set objWord = CreateObject("Word.Application")
Set opnstrBaseDoc=objWord.Documents.Open(strBaseDoc)
Set opnstrNewDoc=objWord.Documents.Open(strNewDoc)
> Comparing 2 documents
Set Dcomp=objWord.Comparedocuments(opnstrBaseDoc,opnstrNewDoc)
RevCount=Dcomp.Revisions.count
If RevCount<>0 Then
'msgbox RevCount
objSheet.Cells(Iterator,4).Value ="There are changes.Please check " &BaseDocName&"_CHANGE.docx file in 'DocumentsWithChanges' folder"
objExcel.ActiveWorkbook.Save
objWord.ActiveDocument.SaveAs2 ("C:\Users\amunaga\Desktop\POC doc comparision\POC\DocumentsWithChanges\"&BaseDocName&"_CHANGE.docx")
objWord.Quit SaveChanges
Set objWord=Nothing
Else
objSheet.Cells(Iterator,4).Value ="No changes in the content"
objWord.Quit SaveChanges
Set objWord=Nothing
End If
End If
Next
objWorkBook.Close
objExcel.Quit
Set objSheet=Nothing
Set objWorkBook=Nothing
Set objExcel=Nothing
Set objFSO = Nothing
How to print the page numbers which has changes after comparing the word documents. I have written the following code to find the differences using vb script. Kindly help in identify and print the page numbers.
I have a directory of files that I want to Loop through and use part of their filename to replace text in a template doc.
For example one filename may be 'NV_AD32_city.dxf'. All files in the directory follow the same filename pattern of XX_XXXX_string.dxf, using two underscores.
I need to capture the string to the right of the first "_" and to the left of the "."so for this example that would be 'AD32_city'
How do I script to use capture that text of the active file to replace text in the template? I guess I need to create an object? But what is the object to use for the current file from a directory?
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Thx for the replies, guys. After several days of trying your code I am just not "getting it". I understand it is set up to take the part of the filename's string that I want but how do I tell the script to use the current file I am looping through? Here is my script so far. I have your code on line 20 under the Sub 'GetNewInputs'
Set fso = CreateObject("Scripting.FileSystemObject")
Option Explicit
Dim WritePath : WritePath = "S:\TempFolder\"
Dim OutFile : OutFile = "VEG_DXF-2-SHP_script-"
Dim WorkingFile : WorkingFile = GetFileContent(SelectFile())
Dim NewState, NewSection, NewArea
Dim OldState, OldSection, OldArea
Call GetNewInputs()
Call GetOldInputs()
Sub GetNewInputs()
NewState = UCase(InputBox("INPUT STATE:", _
"INPUT STATE", "SOCAL"))
NewSection = ("Section_" & InputBox("INPUT SECTION NUMBER:", _
"INPUT SECTION", "14"))
NewArea = "^[^_]+_(.*)\.dxf$"
End Sub
Private Sub GetOldInputs()
OldState = "XX"
OldSection = "_X"
OldArea = "ZZZZ"
End Sub
Function SelectFile()
SelectFile = vbNullString
Dim objShell : Set objShell = WScript.CreateObject("WScript.Shell")
Dim strMSHTA : strMSHTA = "mshta.exe ""about:" & "<" & "input type=file id=FILE>" _
&"<" & "script>FILE.click();new ActiveXObject('Scripting.FileSystemObject')" _
&".GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);" & "<" & "/script>"""
SelectFile = objShell.Exec(strMSHTA).StdOut.ReadLine()
If SelectFile = vbNullString Then
WScript.Echo "No file selected or not a text file."
WScript.Quit
End If
End Function
Private Function GetFileContent(filePath)
Dim objFS, objFile, objTS
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFile = objFS.GetFile(filePath)
Set objTS = objFile.OpenAsTextStream(1, 0)
GetFileContent = objTS.Read(objFile.Size)
Set objTS = Nothing
End Function
For Each FileRefIn fso.GetFolder("S:\SOCAL\Section_14\Veg DXFs\").Files
NewFile = WorkingFile
NewFile = Replace(NewFile, OldState, NewState)
NewFile = Replace(NewFile, OldSection, NewSection)
NewFile = Replace(NewFile, OldArea, NewArea)
WriteFile NewFile, WritePath & OutFile & ".gms"
WScript.Echo NewArea
Next
Private Sub WriteFile(strLine,fileName)
On Error Resume Next
Dim objFSO, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do Until IsObject(objFile)
Set objFile = objFSO.OpenTextFile(fileName, 8, True)
Loop
objFile.WriteLine strLine
objFile.Close
End Sub
Well, that’s actually two questions.
To enumerate files in a directory, you can use FileSystemObject, like this (untested)
const strFolderPath = "C:\Temp\Whatever"
set objFSO = CreateObject( "Scripting.FileSystemObject" )
set objFolder = objFSO.GetFolder( strFolderPath )
set colFiles = objFolder.Files
for each objFile in colFiles
' Do whatever you want with objFile
next
Here's the reference of those objects properties/methods.
And to extract portion of file names, you could use a regular expression.
Here’s some guide how to use'em in VBScript.
The following expression should work for you, it will capture the portion of that file names you asked for:
"^[^_]+_(.*)\.dxf$"
If you need to edit the content of the .dxf files, you will need to work within the AutoCAD VBA (Visual Basic for Applications) environment.
If that is the case, you will need to start with something like below:
GetObject("AutoCAD.Application.20")
CreateObject("AutoCAD.Application.20")
https://knowledge.autodesk.com/search-result/caas/CloudHelp/cloudhelp/2015/ENU/AutoCAD-ActiveX/files/GUID-0225808C-8C91-407B-990C-15AB966FFFA8-htm.html
** Please take note that "VBA is no longer distributed with the AutoCAD installation; it must be downloaded and installed separately. The VBA Enabler for Autodesk AutoCAD can be downloaded here."
I am redesigning our department website and our IT department does not support the intranet development. The server runs ASP Classic and is able to run VB scripts and Javascript to an extent (somethings work others don't).
So here is my problem:
I modified a simple code that I got from http://www.brainjar.com/asp/dirlist/
to list all the PDF Files in a directory including sub directories but I am not sure how to sort it.
As of now it sorts it in alphabetical order per each folder it reads. I would like it to sort every file of every sub directory by the item.DateLastModified property I do not know if this possible.
I am thinking I would need to store the items in an array and then sort the array and print the data but I have no idea how to do that it has been 10 years since I took a programming course.
Any help would be greatly appreciated!
Current code I am using :
====>
<% sub ListFolderContents(path)
dim fs, folder, file, item, url
set fs = CreateObject("Scripting.FileSystemObject")
set folder = fs.GetFolder(path)
for each item in folder.SubFolders
ListFolderContents(item.Path)
next
'Display a list of files
for each item in folder.Files
url = MapURL(item.path)
if item.type = "PDF File" then
Response.Write("<dt>" & item.Name & "" _
& vbCrLf)
end if
next
Response.Write("</dt>" & vbCrLf)
end sub
function MapURL(path)
dim rootPath, url
'Convert a physical file path to a URL for hypertext links.
rootPath = Server.MapPath("/")
url = Right(path, Len(path) - Len(rootPath))
MapURL = Replace(url, "\", "/")
end function %>
The original is at http://www.brainjar.com/asp/dirlist/
Well, it's your lucky day! I happen to have old code that I wrote for personal use ~10 years ago, so with little tweaking it can fit your case almost perfectly. The key is using a disconnected recordset to hold all the data, then sort by date last modified. The crawling itself is similar to what you already have, by recursion. Note that no need to create new folder instance in each iteration - it's waste of resources, since you already have the folder object in the loop.
Anyway, here it is:
Const adVarChar = 200
Const adInteger = 3
Const adDate = 7
Dim objFSO, oFolder, objRS
Sub ExtractAllFiles(oFolder)
Dim oSubFolder, oFile
'recurse all sub folders
For Each oSubFolder In oFolder.SubFolders
Call ExtractAllFiles(oSubFolder)
Next
'loop through all the files found, add to the recordset
For Each oFile in oFolder.Files
objRS.AddNew
objRS.Fields("Name").Value = oFile.Name
objRS.Fields("Url").Value = MapURL(oFile.Path)
objRS.Fields("Type") = oFile.Type
objRS.Fields("DateLastModified").Value = oFile.DateLastModified
Next
End Sub
Sub ListFolderContents(sPath, sTypeToShow)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oFolder = objFSO.GetFolder(sPath)
'create a disconnected recordset
Set objRS = Server.CreateObject("ADODB.Recordset")
'append proper fields
objRS.Fields.Append "Name", adVarChar, 255
objRS.Fields.Append "Url", adVarChar, 255
objRS.Fields.Append "Type", adVarChar, 255
objRS.Fields.Append "DateLastModified", adDate
objRS.Open
'extract all files in given path:
Call ExtractAllFiles(oFolder)
'sort and apply:
If Not(objRS.EOF) Then
objRS.Sort = "DateLastModified DESC"
objRS.MoveFirst
End If
'loop through all the records:
Do Until objRS.EOF
If (Len(sTypeToShow)=0) Or (LCase(sTypeToShow)=LCase(objRS("Type"))) Then
Response.Write("<dt>" & objRS("Name") & " (Type: " & objRS("Type") & ", Last modified: " & objRS("DateLastModified") & ")</dt>" _
& vbCrLf)
End If
objRS.MoveNext()
Loop
'clean up resources
Set oFolder = Nothing
Set objFSO = Nothing
objRS.Close
Set objRS = Nothing
End Sub
To use it in your code, have such line in the HTML body:
<% Call ListFolderContents(Server.MapPath("."), "PDF File") %>
You can of course use different path and change the display to show only what you need.
Hello guys I have an issue or issues with my code above
I'm trying to get "sExtension" to be search in a different folder other that the one I'm using to save my script since this script will be use as a Startup Script on many computers
(It works only if I run the script in the same folder "sExtension", "ExtAssign.txt" and sComputername are otherwise it wont find the path)
This is what it should do
Read a file called "ExtAssign.txt" (There is a full list of computer names in that file) and if it find the computer name on that file then it should copy a file with the with the extension number assigned to that computer name from a file server to "C:\" Drive
For this example I'm trying to do this locally, If I can make it then I'll try it from my File Server
Set objFSO = CreateObject("Scripting.FileSystemObject")
set oFso = CreateObject("Scripting.FileSystemObject")
Set objFS = CreateObject("Scripting.FileSystemObject")
Set fso = CreateObject("Scripting.FileSystemObject")
set oShell = WScript.CreateObject("WScript.Shell")
set oShellEnv = oShell.Environment("Process")
Set folder = Fso.GetFolder("C:\Users\XXXXX\Desktop\Test\Extensions\")
Set wshshell = CreateObject("WScript.Shell")
Set objNetwork = CreateObject("WScript.Network")
Set ObjEnv = WshShell.Environment("Process")
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
Scomputername = ObjEnv("COMPUTERNAME")
Set objFSO = CreateObject("Scripting.FileSystemObject")
set objWShell = wScript.createObject("WScript.Shell")
Dim strFile
'File to scan
strFile = "C:\Users\XXXXX\Desktop\Test\Extensions\Extassign\ExtAssign.txt"
Dim strPattern
'Look for computer name in file
strPattern = scomputername
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
Set objFile = objFS.OpenTextFile(strFile)
Do Until objFile.AtEndOfStream
Dim strLine
'Read each line and store it in strLine
strLine = objFile.ReadLine
'If the line matches the computer name, save the line to ExtArray
If InStr(strLine,strPattern)>0 Then
Dim ExtArray
'Split the line and separate the extension
ExtArray = Split(strLine,"|", -1, 1)
Dim sExtension
'Save the extension to sExtension
sExtension=ExtArray(1)
End If
Loop
'If the sExtension is empty, computer was not found, send message and terminate script.
If sExtension="" Then
WScript.Echo "ERROR: Computer "& scomputername &" not found in Extension Assignment List, so no extension has been set. Avaya will not be launched. Please contact your IT department for assistance."
Else
'If the sExtension contains a number, Copy that file to C:\ and rename it to Config.xml
fso.CopyFile "C:\Users\XXXXX\Desktop\Test\Extensions\ "& sExtension &"", "C:\Config.xml", True
End If
at the end it if it finds the file sExtension it will rename it to Config.xml but it wont do it unless I run the script in the same folder sExtension and sComputername.
I get File not found error
Thank you in advance and Happy new year!
The culprit is most likely this line:
fso.CopyFile "C:\Users\XXXXX\Desktop\Test\Extensions\ "& sExtension &"", "C:\Config.xml", True
There is a trailing space after the last backslash in the path, so you're creating a path
C:\Users\XXXXX\Desktop\Test\Extensions\ 12345
^
when you actually want a path
C:\Users\XXXXX\Desktop\Test\Extensions\12345
On a more general note: why are you creating 7(!) FileSystemObject instances (replacing one of them three times on top of that)? And 3(!) WScript.Shell instances? You don't even use most of them, not to mention that you don't need the Shell object in the first place. You only use it for determining the computer name, which could be done just fine using the WScript.Network object (that you don't use at all).
Also, please don't ever use comments like this:
'Read each line and store it in strLine
strLine = objFile.ReadLine
It's quite obvious that you read each line and assign it to the variable strLine. Comments shouldn't rephrase what you're doing (the code already does that, at least when you're using speaking variable and function names), but why you're doing it, i.e. what the purpose of a particular code section is.
Your code could be reduced to something as simple as this:
Set fso = CreateObject("Scripting.FileSystemObject")
Set net = CreateObject("WScript.Network")
computername = net.ComputerName
foldername = "C:\Users\XXXXX\Desktop\Test\Extensions"
filename = fso.BuildPath(foldername, "Extassign\ExtAssign.txt")
Set f = fso.OpenTextFile(filename)
Do Until f.AtEndOfStream
line = f.ReadLine
If InStr(line, computername) > 0 Then
arr = Split(line, "|", -1, 1)
If UBound(arr) >= 1 Then extension = arr(1)
End If
Loop
f.Close
If IsEmpty(extension) Then
WScript.Echo "ERROR: Computer "& computername &" not found in ..."
Else
fso.CopyFile fso.BuildPath(foldername, extension), "C:\Config.xml", True
End If
I have a problem - instances of Excel and Word behave differently in the same procedure. Have a look at the code. The idea there is to have a procedure that handles resaving files in excel and word in various format combinations.
The problem is that I notice that word and excel behave differently - the appWord and appExcel have different type names. At some point appWord is changed from Application to Object, which then makes it impossible to close it. I don't understand the differences in the behaviour, since the code applied to them is identical.
Option Explicit
Dim fso
Dim appWord
Dim appExcel
Set fso = CreateObject("Scripting.FileSystemObject")
startWord
ResaveFiles appWord.Documents, "docx", 12, 0
appWord.quit
startExcel
ResaveFiles appExcel.Workbooks, "xlsx", 51, 56
appExcel.quit
MsgBox "All done."
Sub ResaveFiles(appType, srcExtName, srcExtNum, tmpExtNum)
Dim objFile
Dim objOpenFile
Dim strDirectory
For Each objFile in fso.GetFolder(".").Files
If lcase(fso.GetExtensionName(objFile)) = srcExtName Then
If typeName(appType) = "Documents" Then StartWord
If typeName(appType) = "Workbooks" Then StartExcel
Set objOpenFile = appType.Open(objFile.path)
strDirectory = fso.BuildPath(objOpenFile.path, fso.GetBaseName(objOpenFile.name) & "._temp")
objOpenFile.SaveAs strDirectory, tmpExtNum
objOpenFile.Close
msgBox typename(appType) & objFile
msgBox typename(appWord) 'First typename test
msgBox Typename(appExcel)
If typeName(appType) = "Documents" Then appWord.Quit
If typeName(appType) = "Workbooks" Then appExcel.Quit
set objOpenFile = appType.Open(strDirectory)
objOpenFile.SaveAs objFile.path, srcExtNum
objOpenFile.Close
fso.DeleteFile(strDirectory)
msgBox typename(appWord) 'Second typename test
msgBox Typename(appExcel)
End If
Next
End Sub
'Start Word
Sub StartWord
Set appWord = CreateObject("Word.Application")
appWord.visible = false
appWord.DisplayAlerts = false
End Sub
'Start Excel
Sub StartExcel
Set appExcel = CreateObject("Excel.Application")
appExcel.visible = false
appExcel.DisplayAlerts = false
End Sub
I have tested it in the following way (with two typename tests) - when there are word files available, first appWord is Application and appExcel is empty, then it changes to Object and appExcel stays Empty (in this case we get an error when the subprocedure ends at AppWord.Quit). When there are no word files, and the script is processing Excels, first appWord is Object and appExcel is Application, then appWord is still Object and appExcel is still Application - in this case there are no errors when the subprocedure ends, on the appExcel.Quit.
Maybe i'm wrong, just my opinion:
If typeName(appType) = "Documents" Then appWord.Quit
If typeName(appType) = "Workbooks" Then appExcel.Quit
set objOpenFile = appType.Open(strDirectory)
appType is a reference to what appWord.Documents or appExcel.Workbooks are referencing before entering your ResaveFiles Sub, where you instantiate a new copy of 'Excel.Application' or 'Word.Application', and in each of the cases, you instruct the application TO QUIT. The question is not why in the case of word you got an error. From my point of view YOU SHOULD got an error. The question is why, if instructed to quit, excel keeps open and maintaining references to handle your code.
EDIT - And not tried. Just adapted from OP code. Adapt as needed
Option Explicit
ResaveFiles "Word.Application", "docx", 12, 0
ResaveFiles "Excel.Application", "xlsx", 51, 56
MsgBox "All done."
Sub ResaveFiles(progID, srcExtName, srcExtNum, tmpExtNum )
Dim app, doc
Dim fso, objFile, objOpenFile, strDirectory
Set fso = CreateObject("Scripting.FileSystemObject")
For Each objFile in fso.GetFolder( "." ).Files
If LCase(fso.GetExtensionName( objFile.Name )) = srcExtName Then
' Get references
Set app = GetNewAppInstance( progID )
Set doc = GetDocumentHandler( app )
' Save temp
Set objOpenFile = doc.Open( objFile.Path )
strDirectory = fso.BuildPath( objOpenFile.path, fso.GetBaseName(objOpenFile.name) & "._temp" )
objOpenFile.SaveAs strDirectory, tmpExtNum
objOpenFile.Close
' Release objects
Set objOpenFile = nothing
Set doc = nothing
app.Quit
Set app = nothing
' Get references again
Set app = GetNewAppInstance( progID )
Set doc = GetDocumentHandler( app )
' Resave file
Set objOpenFile = doc.Open( strDirectory )
objOpenFile.SaveAs objFile.path, srcExtNum
objOpenFile.Close
' Release objects
Set objOpenFile = nothing
Set doc = nothing
app.Quit
Set app = nothing
' Clean
fso.DeleteFile(strDirectory)
End If
Next
End Sub
Function GetNewAppInstance( ByVal progID )
Set GetNewAppInstance = CreateObject( progID )
With GetNewAppInstance
.Visible = False
.DisplayAlerts = False
End With
End Function
Function GetDocumentHandler( app )
Dim name
name = app.Name
If InStr(name,"Excel") > 0 Then
Set GetDocumentHandler = app.Workbooks
ElseIf InStr(name,"Word") > 0 Then
Set GetDocumentHandler = app.Documents
Else
Set GetDocumentHandler = app
End If
End Function