Hi the code below merges pdfs using adobe acrobat. It works but I am looking to add page numbers to the document so that if I merge 2 documents that are 4 pages each the page numbers go from 1 to 8. How can that be done?
Here is the code:
'http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
Sub MergePDFs()
' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
' Reference required: "VBE - Tools - References - Acrobat"
' --> Settings, change to suit
Const MyPath = "C:\mypath" '"C:\Temp" ' Path where PDF files are stored
Const MyFiles = "file1.pdf,file2.pdf" ' List of PDFs to ne merged
Const DestFile = "MergedFile.pdf" ' The name of the merged file
' <-- End of settings
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub
attached a stand-alone VBS/VBA script, which add the page number as footer to your pdf. You may took out the parts you need and write into your script just before you save the pdf or execute it afterwards.
Full Script:
File = "D:\Test.pdf"
Set App = CreateObject("Acroexch.app") '//start acrobat
app.show '//show Acrobat or comment out for hidden mode
Set AVDoc = CreateObject("AcroExch.AVDoc")
Set AForm = CreateObject("AFormAut.App") '//get AFormAPI to execute js later
If AVDoc.Open(File,"") Then
'//write JS-Code on a variable
Ex = " // set Date, filename and PageNo as footer "&vbLF _
& " var Box2Width = 50 "&vbLF _
& " for (var p = 0; p < this.numPages; p++) "&vbLF _
& " { "&vbLF _
& " var aRect = this.getPageBox(""Crop"",p); "&vbLF _
& " var TotWidth = aRect[2] - aRect[0] "&vbLF _
& " { var bStart=(TotWidth/2)-(Box2Width/2) "&vbLF _
& " var bEnd=((TotWidth/2)+(Box2Width/2)) "&vbLF _
& " var fp = this.addField(String(""xftPage""+p+1), ""text"", p, [bStart,30,bEnd,15]); "&vbLF _
& " fp.value = ""Page: "" + String(p+1)+ ""/"" + this.numPages; "&vbLF _
& " fp.textSize=6; fp.readonly = true; "&vbLF _
& " fp.alignment=""center""; "&vbLF _
& " } "&vbLF _
& " } "
'//Execute JS-Code
AForm.Fields.ExecuteThisJavaScript Ex
msgBox("Done")
end if
Set AVDoc = Nothing
Set APP = Nothing
The parts you really need if you only want to take over in your script:
Set AForm = CreateObject("AFormAut.App")
Ex = " // set Date, filename and PageNo as footer "&vbLF _
& " .....
& " .....
& " } "
'//Execute JS-Code
AForm.Fields.ExecuteThisJavaScript Ex
This also demonstrates how you can use/execute AcroJs via VBS/VBA without translating to JSO (Java Script Object).
Good luck, Reinhard
Related
so I was wondering if i could get some help here. so basically i am trying to find out how to write a dat file that will be able to import splines into Catia. These splines when imported are supposed to act like meshes on a structure, that is, picture a meshed structure, but instead of mesh it will be splines on it. so right now i thought to learn a macro that exports a few splines i created on a structure into a text(.dat) file. but i have been having troubles with the macro i have as it asks me to select a spline, but wont allow me to click on the spline in spec tree. The thing is that i have lots of splines and i would like the macro to just select splines automatically without asking and export them..... PLS HELP ME. thanks alot.
So here is the code:
Sub CATMain()
'*** *** Definition Variables
Dim CtrlPoint()
Dim oCoordinates(1)
Dim StartKrit As Integer
'*** Query document type ***
StartKrit = 0
Set oDoc = CATIA.ActiveDocument
ObjType = TypeName(oDoc)
If ObjType = "PartDocument" Then
DocType = "Part"
StartKrit = 1
ElseIf ObjType = "DrawingDocument" Then
DocType = "Drawing "
StartKrit = 1
End If
If StartKrit = 0 Then
box = MsgBox(" The active document is neither a CATPart still CATDrawing! " + Chr(10) + _
" The macro can not continue and will now exit " + Chr(10) + _
"Please select a CATPart or a CATDrawing and start the macro again!", vbCritical + vbOKOnly, "incorrect document type")
Exit Sub
End If
'*** Create the * .txt files ***
StorePath = "C: \"
StoreName = "Splinekoordinaten" & Date
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(StorePath & StoreName & ".txt ") = True Then
box = MsgBox(" file ==> " + StorePath + StoreName + " <== already exists! " + Chr(10) + " Do you want to overwrite the file? ", vbCritical + vbYesNo, "file already exists ")
If box = vbNo Then
box = MsgBox(" The macro is now finished ", vbInformation + vbOKOnly, " the user stops ")
Exit Sub
End If
End If
Set A = fs.CreateTextFile("D:\school\INTERNSHIP\Macro\Newest.txt ", True)
A.WriteLine (" points coordinates of a spline ")
A.WriteLine (" ")
If DocType = " Part " Then
A.WriteLine (" name of CATParts: " & oDoc.Name)
ElseIf DocType = " Drawing " Then
A.WriteLine ("name of CATDrawing:" & oDoc.Name)
End If
A.WriteLine ("")
'*** Readout from the CATDrawing ***
If DocType = "Drawing" Then
Dim otype2D(0)
Dim Selection
Set mysel = oDoc.Selection
mysel.Clear
otype2D(0) = "Spline2D"
mysel.Clear
box = MsgBox(" Please select now the spline ", vbInformation + vbOKCancel, " spline Select ")
If box = vbCancel Then
box = MsgBox(" you have the selection canceled " + Chr(10) + _
" the macro is now finished! ", vbCritical, "abort by user")
If fs.FileExists(StorePath & StoreName & ".txt") = True Then
A.Close
fs.DeleteFile (StorePath & StoreName & ".txt")
End If
Exit Sub
End If
Selection = mysel.SelectElement2(otype2D, "Please select the spline", False)
If Selection = "Normal" Then
oSplineName = mysel.Item(1).Value.Name
Set oSpline = mysel.Item(1).Value
A.WriteLine ("name of the selected spline:" & oSplineName)
A.WriteLine ("")
A.WriteLine ("")
Else
box = MsgBox("you have canceled the selection" + Chr(10) + _
"the macro is now finished! ", vbCritical, " abort by user ")
If fs.FileExists(StorePath & StoreName & " .txt ") = True Then
A.Close
fs.DeleteFile (StorePath & StoreName & " .txt ")
End If
Exit Sub
End If
mysel.Clear
Set QuCtrlP = oSpline.EndPoint
QuCtrlPRaw = QuCtrlP.Name
QuCtrlPSemi = Split(QuCtrlPRaw, ".")
QuCtrlPFin = QuCtrlPSemi(1) - 1
ReDim Preserve CtrlPoint(QuCtrlPFin)
For j = 0 To QuCtrlPFin
Set CtrlPoint(j) = oSpline.GetItem("Ktrl-point." & j + 1)
CtrlPoint(j).GetCoordinates oCoordinates
A.WriteLine ("point" & j + 1 & "X / Y")
A.WriteLine (oCoordinates(0))
A.WriteLine (oCoordinates(1))
A.WriteLine ("")
Next
'*** readout from the CATPart ***
ElseIf DocType = "Part" Then
Dim otype3D(0)
Set mysel = oDoc.Selection
mysel.Clear
otype3D(0) = "Spline2D"
mysel.Clear
box = MsgBox("Please select now the spline", vbInformation + vbOKCancel, "spline Select")
If box = vbCancel Then
box = MsgBox("you have canceled the selection" + Chr(10) + _
"The macro is now finished!", vbCritical, "abort by user")
If fs.FileExists(StorePath & StoreName & ".txt") = True Then
A.Close
fs.DeleteFile (StorePath & StoreName & ".txt ")
End If
Exit Sub
End If
Selection = mysel.SelectElement2(otype3D, " Please select the spline ", False)
If Selection = " Normal " Then
oSplineName = mysel.Item(1).Value.Name
Set oSpline = mysel.Item(1).Value
A.WriteLine ("name of the selected spline:" & oSplineName)
A.WriteLine ("")
A.WriteLine ("")
Else
box = MsgBox("you have canceled the selection" + Chr(10) + _
"The macro is now finished!", vbCritical, "abort by user")
If fs.FileExists(StorePath & StoreName & ".txt") = True Then
A.Close
fs.DeleteFile (StorePath & StoreName & " .txt ")
End If
Exit Sub
End If
mysel.Clear
Set QuCtrlP = oSpline.EndPoint
QuCtrlPRaw = QuCtrlP.Name
QuCtrlPSemi = Split(QuCtrlPRaw, " ")
QuCtrlPFin = QuCtrlPSemi(1) - 1
ReDim Preserve CtrlPoint(QuCtrlPFin)
For j = 0 To QuCtrlPFin
Set CtrlPoint(j) = oSpline.GetItem("Ktrl-point." & j + 1)
CtrlPoint(j).GetCoordinates oCoordinates
A.WriteLine ("point" & j + 1 & "X / Y")
A.WriteLine (oCoordinates(0))
A.WriteLine (oCoordinates(1))
A.WriteLine ("")
Next
End If
'**** Issue Storage Location ****
Ml = "The macro has completed successfully"
M2 = "The * .txt file is saved under the following path:"
M2_ZU_1 = "==>"
M2_ZU_2 = "<== "
M3 = " Are you in the path now oeffnen? "
Title = "memory data"
skin = vbInformation + vbYesNo
query = MsgBox(Ml + Chr(10) + Chr(10) + M2 + Chr(10) + Chr(10) + M2_ZU_1 + StorePath + StoreName + M2_ZU_2 + Chr(10) + Chr(10) + M3, skin, Title)
If query = vbYes Then
ExplorerPath = "C: \ WINDOWS \ explorer.exe"
Explorer = CATIA.SystemService.ExecuteProcessus(ExplorerPath & "" & StorePath)
End If
End Sub
Your selectelement2 filter is set for spline2D, are you selected sketch splines or 3d splines?
If you are working with 3d splines like it sounds, you want to use this code:
mysel.Clear
otype3D(0) = "HybridShapeSpline"
mysel.Clear
box = MsgBox("Please select now the spline", vbInformation + vbOKCancel, "spline Select")
If box = vbCancel Then
box = MsgBox("you have canceled the selection" + Chr(10) + _
"The macro is now finished!", vbCritical, "abort by user")
If fs.FileExists(StorePath & StoreName & ".txt") = True Then
A.Close
fs.DeleteFile (StorePath & StoreName & ".txt ")
End If
Exit Sub
End If
Selection = mysel.SelectElement2(otype3D, " Please select the spline ", False)
You'll find more help on www.coe.org, there is a significant group of CATIA automators there.
The problem of this script is that it shows an unknown error Message while running the script.
I called the function by echo method in my ftp which is "filezilla".
every thing is working fine as it logs into the server check for the path, open channel for data writing. Still dont know where is the problem
Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath)
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Const OpenAsDefault = -2
Const FailIfNotExist = 0
Const ForReading = 1
Const ForWriting = 2
Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
Set oFTPScriptShell = CreateObject("WScript.Shell")
sRemotePath = Trim(sRemotePath)
sLocalFile = Trim(sLocalFile)
'----------Path Checks---------
'Here we willcheck the path, if it contains
'spaces then we need to add quotes to ensure
'it parses correctly.
If InStr(sRemotePath, " ") > 0 Then
If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
sRemotePath = """" & sRemotePath & """"
End If
End If
If InStr(sLocalFile, " ") > 0 Then
If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
sLocalFile = """" & sLocalFile & """"
End If
End If
'Check to ensure that a remote path was
'passed. If it's blank then pass a "\"
If Len(sRemotePath) = 0 Then
'Please note that no premptive checking of the
'remote path is done. If it does not exist for some
'reason. Unexpected results may occur.
sRemotePath = "\"
End If
'Check the local path and file to ensure
'that either the a file that exists was
'passed or a wildcard was passed.
If InStr(sLocalFile, "*") Then
If InStr(sLocalFile, " ") Then
FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _
"space." & vbCRLF
FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client."
Exit Function
End If
ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
'nothing to upload
FTPUpload = "Error: File Not Found."
Exit Function
End If
'--------END Path Checks---------
'build input file for ftp command
sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF
sFTPScript = sFTPScript & sPassword & vbCRLF
sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF
sFTPScript = sFTPScript & "binary" & vbCRLF
sFTPScript = sFTPScript & "prompt n" & vbCRLF
sFTPScript = sFTPScript & "put " & sLocalFile & vbCRLF
sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
'Write the input file for the ftp command
'to a temporary file.
Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
fFTPScript.WriteLine(sFTPScript)
fFTPScript.Close
Set fFTPScript = Nothing
oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
" > " & sFTPResults, 0, TRUE
Wscript.Sleep 1000
'Check results of transfer.
Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
FailIfNotExist, OpenAsDefault)
sResults = fFTPResults.ReadAll
fFTPResults.Close
oFTPScriptFSO.DeleteFile(sFTPTempFile)
oFTPScriptFSO.DeleteFile (sFTPResults)
If InStr(sResults, "226 Transfer complete.") > 0 Then
FTPUpload = True
ElseIf InStr(sResults, "File not found") > 0 Then
FTPUpload = "Error: File Not Found"
ElseIf InStr(sResults, "cannot log in.") > 0 Then
FTPUpload = "Error: Login Failed."
Else
FTPUpload = "Error: Unknown."
End If
Set oFTPScriptFSO = Nothing
Set oFTPScriptShell = Nothing
WScript.Echo "Process Completed (" & Now & ")"
End Function
I am trying to do the following thing from Excel vba:
Export certain worksheets to pdf
Take an existing pdf document and insert it in the newly generated pdf at a specific place (not necessarily at the end or at the beginning)
Number the pages of the merged pdf, omitting two title pages
I already figured out the first step. For the second and third step, I have Adobe Acrobat XI Pro at my disposal. Since I want to do this in one go from vba, I have downloaded the Acrobat SDK. From some quick Googling, I think I should be able to figure out the second step now, using the IAC, but the third step (oddly) seems the most difficult. Any suggestions would be welcome.
Best,
NiH
In the meantime, I found a solution for adding page numbers. For anyone who might be interested, here's an example of how it can be done:
Sub addPageNumbers()
Dim acroApp As Acrobat.acroApp
Dim myDocument As Acrobat.AcroPDDoc
Dim jso As Object
Dim strPath As String
Dim strFileName As String
Dim intPages As Integer
Dim i As Integer
Set acroApp = CreateObject("AcroExch.App")
Set myDocument = CreateObject("AcroExch.PDDOc")
strPath = "C:\"
strFileName = "myDoc.pdf"
'Open file and load JSObject
Set myDocument = CreateObject("AcroExch.PDDOc")
myDocument.Open (strPath & strFileName)
Set jso = myDocument.GetJSObject
' get number of pages
intPages = myDocument.GetNumPages
'Write page numbers to all pages
For i = 1 To intPages
jso.addWatermarkFromText _
cText:=Str(i) & " ", _
nTextAlign:=1, _
nHorizAlign:=2, _
nVertAlign:=4, _
nStart:=i - 1, _
nEnd:=i - 1
Next i
'Save document
Call myDocument.Save(1, strPath & strFileName)
'Clean up
Set jso = Nothing
Call acroApp.CloseAllDocs
Set myDocument = Nothing
Call acroApp.Exit
Set acroApp = Nothing
End Sub
Keep in mind that you need to have Acrobat (not only the reader) installed on your computer, and the reference to Acrobat has to be enabled in the vba editor.
I did not add error handling; obviously you should.
More info on the addwatermarkFromText method can be found here
Best regards,
NiH
Here another method to do it. I use the add field method from acrobat js. The "ExecuteThisJavaScript" method has the advantage that you can use js without translation to js-object.
The following example - I published somewhere already - add Date, filename and pageNo as footer to a pdf. It's written in VBS but can also used as vba without changes.
Best regards, Reinhard
File = "D:\Test.pdf"
Set App = CreateObject("Acroexch.app") '//start acrobat
app.show '//show Acrobat or comment out for hidden mode
Set AVDoc = CreateObject("AcroExch.AVDoc")
Set AForm = CreateObject("AFormAut.App") '//get AFormAPI to execute js later
If AVDoc.Open(File,"") Then
'//write JS-Code on a variable
Ex = " // set Date, filename and PageNo as footer "&vbLF _
& " var Box2Width = 50 "&vbLF _
& " for (var p = 0; p < this.numPages; p++) "&vbLF _
& " { "&vbLF _
& " var aRect = this.getPageBox(""Crop"",p); "&vbLF _
& " var TotWidth = aRect[2] - aRect[0] "&vbLF _
& " { var bStart=(TotWidth/2)-(Box2Width/2) "&vbLF _
& " var bEnd=((TotWidth/2)+(Box2Width/2)) "&vbLF _
& " var fp = this.addField(String(""xftPage""+p+1), ""text"", p, [bStart,30,bEnd,15]); "&vbLF _
& " fp.value = ""Page: "" + String(p+1)+ ""/"" + this.numPages; "&vbLF _
& " fp.textSize=6; fp.readonly = true; "&vbLF _
& " fp.alignment=""center""; "&vbLF _
& " } "&vbLF _
& " } "
'//Execute JS-Code
AForm.Fields.ExecuteThisJavaScript Ex
msgBox("Done")
end if
Set AVDoc = Nothing
Set APP = Nothing
I want to monitor a drive for file changes, using VBScript. I have the below code. It works fine for InstanceCreationEvent and InstanceDeletionEvent. But InstanceModificationEvent is not happening. From googling I got to know we need to use CIM_DataFile instead of CIM_DirectoryContainsFile to monitor InstanceModificationEvent. I am not sure how to modify the code. Can anyone help.
FYI: One script should monitor all the folders and subfolders in a drive.
PS: Any suggestion to improve the code and performance or other ideas also welcome.
My Code:
Dim arrFolders
Dim strComputer
Dim objWMIService
Dim strFolder
Dim strCommand
Dim i
Dim strQuery
strChangeFile = "MonitorFolder_Log.txt"
strMailIDFile = "MonitorFolder_MailIDs.txt"
'Check if the log file exists, if not ceate a new file and exit the script. Restart the script again.
Set oFSO = CreateObject("Scripting.FileSystemObject")
If not oFSO.FileExists(strChangeFile) then
'WScript.Echo "Change Log File Not Found. Creating new file..."
Set oTxtFile = oFSO.CreateTextFile(strChangeFile)
WScript.Echo strChangeFile & " File Created." & vbCrLf & "Please restart the script." & vbCrLf
WScript.Quit
End If
'Prompt for which drive should be monitored. If not a valid drive, then exit the script.
strDrive = InputBox("Enter the drive to monitor: " & vbCrLf & "E.g.: Input C to monitor C:\ drive.", "Monitor Folder - Oracle", "E")
If strDrive = "" then
WScript.Echo "Not a valid drive. Terminating the script."
WScript.Quit
End If
'Append ":" with the drive name.
strDrive = strDrive & ":"
'Read the mail IDs.
Set objFSOMailID = CreateObject("Scripting.FileSystemObject")
Set oTSMailID = objFSOMailID.OpenTextFile(strMailIDFile)
strMailIDsList = oTSMailID.ReadAll
oTSMailID.close
'WScript.Echo strMailIDsList
'Array to store the existing folder paths that should be monitored.
arrFolders = Array()
i = 0
Set FSO = CreateObject("Scripting.FileSystemObject")
ShowSubfolders FSO.GetFolder(strDrive)
Sub ShowSubFolders(Folder)
For Each Subfolder in Folder.SubFolders
i = i + 1
folderPath = "" & Subfolder.Path & ""
folderPath = Replace(folderPath ,"\","\\\\")
ReDim Preserve arrFolders(i)
arrFolders(i) = folderPath
'Wscript.Echo i & " " & arrFolders(i)
ShowSubFolders Subfolder
Next
End Sub
'Set the first path to be the drive.
arrFolders(0) = strDrive & "\\\\"
'Use WMI query to get the file changes.
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
'Loop throught the array of folders setting up the monitor for Each
i = 0
For Each strFolder In arrFolders
'Create the event sink
'WScript.Echo "setup for folder: " & strFolder & vbLf
strCommand = "Set EventSink" & i & " = WScript.CreateObject" & "(""WbemScripting.SWbemSink"", ""SINK" & i & "_"")"
ExecuteGlobal strCommand
'Setup Notification
strQuery = "SELECT * " _
& "FROM __InstanceOperationEvent " _
& "WITHIN 1 " _
& "WHERE Targetinstance ISA 'CIM_DirectoryContainsFile'" _
& " AND TargetInstance.GroupComponent = " & "'Win32_Directory.Name=""" & strFolder & """'"
strCommand = "objWMIservice.ExecNotificationQueryAsync EventSink" & i & ", strQuery"
ExecuteGlobal strCommand
'Create the OnObjectReady Sub
strCommand = "Sub SINK" & i & "_OnObjectReady(objObject, " & "objAsyncContext)" & vbLf _
& " 'Wscript.Echo objObject.TargetInstance.PartComponent" & vbLf _
& " SendNotification(objObject)" & vbLf _
& "End Sub"
'WScript.Echo strCommand
ExecuteGlobal strCommand
i = i + 1
Next
'Wait for events.
WScript.Echo "Waiting for events..."
i = 0
While (True)
Wscript.Sleep(1000)
Wend
Function SendNotification(objObject)
strEventType = objObject.Path_.Class
strPartComp = Split(objObject.TargetInstance.PartComponent, "=")
strFileName = Replace(strPartComp(1), "\\", "\")
WScript.Echo strEventType
WScript.Echo strFileName
'Some more code to send mail and logs...
End Function
Monitoring the entire filesystem for file creation is not feasible. It will eat up system resources and might severly affect system operation. Only ever monitor selected folders. The following should work:
Const Interval = 1
Set monitor = CreateMonitor("C:\foo")
Do
Set evt = monitor.NextEvent()
Select Case evt.Path_.Class
Case "__InstanceCreationEvent" : SendNotification evt.TargetInstance
Case "__InstanceModificationEvent" : ...
Case "__InstanceDeletionEvent" : ...
End Select
Loop
Function CreateMonitor(path)
Set wmi = GetObject("winmgmts://./root/cimv2")
Set fso = CreateObject("Scripting.FileSystemObject")
path = Split(fso.GetAbsolutePathName(path), ":")
drv = path(0) & ":"
dir = Replace(path(1), "\", "\\")
If Right(dir, 2) <> "\\" Then dir = dir & "\\"
query = "SELECT * FROM __InstanceOperationEvent" & _
" WITHIN " & Interval & _
" WHERE Targetinstance ISA 'CIM_DataFile'" & _
" AND TargetInstance.Drive='" & drv & "'" & _
" AND TargetInstance.Path='" & dir & "'"
Set CreateMonitor = wmi.ExecNotificationQuery(query)
End Function
Sub SendNotification(tgtInst)
'send notification
End Sub
You should run monitors for different folders as separate processes, because NextEvent() is a blocking operation.
I'm running the following WMI script to get the associations between drive letters and physical drives on the system, but for some reason it omits CDROMs/DVD-ROMs. Can someone tell me how to get those as well?
ComputerName = "."
Set wmiServices = GetObject _
("winmgmts:{impersonationLevel=Impersonate}!//" & ComputerName)
Set wmiDiskDrives = wmiServices.ExecQuery _
("SELECT DeviceID FROM Win32_DiskDrive")
For Each wmiDiskDrive In wmiDiskDrives
strEscapedDeviceID = _
Replace(wmiDiskDrive.DeviceID, "\", "\\", 1, -1, vbTextCompare)
Set wmiDiskPartitions = wmiServices.ExecQuery _
("ASSOCIATORS OF {Win32_DiskDrive.DeviceID=""" & _
strEscapedDeviceID & """} WHERE " & _
"AssocClass = Win32_DiskDriveToDiskPartition")
For Each wmiDiskPartition In wmiDiskPartitions
Set wmiLogicalDisks = wmiServices.ExecQuery _
("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & _
wmiDiskPartition.DeviceID & """} WHERE " & _
"AssocClass = Win32_LogicalDiskToPartition")
For Each wmiLogicalDisk In wmiLogicalDisks
WScript.Echo wmiLogicalDisk.DeviceID & " = " & wmiDiskDrive.DeviceID
Next
Next
Next
Considering all of the comments thus far, here is a script that adds the capability to list CD-Rom drives.
ComputerName = "."
Set dictDrives = CreateObject("Scripting.Dictionary")
Set listDriveLetters = CreateObject("System.Collections.ArrayList")
Set wmiServices = GetObject _
("winmgmts:{impersonationLevel=Impersonate}!//" & ComputerName)
Set wmiDiskDrives = wmiServices.ExecQuery _
("SELECT DeviceID FROM Win32_DiskDrive")
For Each wmiDiskDrive In wmiDiskDrives
strEscapedDeviceID = Replace(wmiDiskDrive.DeviceID, "\", "\\", 1, -1, vbTextCompare)
Set wmiDiskPartitions = wmiServices.ExecQuery _
("ASSOCIATORS OF {Win32_DiskDrive.DeviceID=""" & _
strEscapedDeviceID & """} WHERE " & _
"AssocClass = Win32_DiskDriveToDiskPartition")
For Each wmiDiskPartition In wmiDiskPartitions
Set wmiLogicalDisks = wmiServices.ExecQuery _
("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & _
wmiDiskPartition.DeviceID & """} WHERE " & _
"AssocClass = Win32_LogicalDiskToPartition")
For Each wmiLogicalDisk In wmiLogicalDisks
listDriveLetters.Add wmiLogicalDisk.DeviceID
dictDrives.Add wmiLogicalDisk.DeviceID, wmiDiskDrive.DeviceID
Next
Next
Next
Set wmiCDROMDrives = wmiServices.ExecQuery _
("Select DeviceID, Drive, MediaLoaded from Win32_CDROMDrive")
For Each wmiCDROMDrive in wmiCDROMDrives
If wmiCDROMDrive.MediaLoaded Then ' Only show drives with inserted media
listDriveLetters.Add wmiCDROMDrive.Drive
dictDrives.Add wmiCDROMDrive.Drive, wmiCDROMDrive.DeviceID
End If
Next
listDriveLetters.Sort ' List the drives in alphabetical order
For Each strDriveLetter in listDriveLetters
WScript.Echo strDriveLetter & " = " & dictDrives.Item(strDriveLetter)
Next
I think you wouldn need to use the Win32_CDROMDrive WMI class to access CD-ROM info. The code you have above is looking for physical drives in the Win32_DiskDrive class, it excludes CD_ROM
You could additional lines to get similar data - but not the same given CD-ROMs don't have the Partition characteristics that your current code does
ComputerName = "."
Set wmiServices = GetObject _
("winmgmts:{impersonationLevel=Impersonate}!//" & ComputerName)
Set wmiDiskDrives = wmiServices.ExecQuery _
("SELECT * FROM Win32_CDROMDrive")
For Each wmiDiskDrive In wmiDiskDrives
MsgBox wmiDiskDrive.drive & "=" & wmiDiskDrive.DeviceID
Next
Instead I think this different VBS may do what you want - the may part as I dont think the partition info is relevant to you.
vbs version
Dim objFSO
Dim colDrives
Dim strOut
Dim strArray
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set colDrives = objFSO.Drives
strArray = Array("Unknown", "Removable", "Fixed", "Network", "CD-ROM", "RAM Disk")
On Error Resume Next
'File system errors for virtual drives
For Each objDrive In colDrives
strOut = "Drive letter: " & objDrive.DriveLetter & vbNewLine
strOut = strOut & ("Drive type: " & strArray(objDrive.DriveType) & vbNewLine)
strOut = strOut & ("File system: " & objDrive.FileSystem & vbNewLine)
strOut = strOut & ("Path: " & objDrive.Path)
wscript.echo strOut
Next
On Error GoTo 0
vba version
Sub Test()
Dim objFSO As Object
Dim colDrives As Object
Dim strOut As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set colDrives = objFSO.Drives
On Error Resume Next
'File system errors for virtual drives
For Each objDrive In colDrives
strOut = "Drive letter: " & objDrive.DriveLetter & vbNewLine
strOut = strOut & ("Drive type: " & Choose(objDrive.DriveType + 1, "Unknown", "Removable", "Fixed", "Network", "CD-ROM", "RAM Disk") & vbNewLine)
strOut = strOut & ("File system: " & objDrive.FileSystem & vbNewLine)
strOut = strOut & ("Path: " & objDrive.Path)
MsgBox strOut
Next
On Error GoTo 0
End Sub