Yesterday we have finalized and tested the code (the first part of the code is VBScript) and the second part of the code is (in Excel VBA) to move file from one source folder to one destination folder successfully based on two hour delay (i.e. each file which will come to source folder will upload 2 hour delay), however the situation is that i have actually 15 source folders and 15 destination folders.
One method is that i should create 15 VBScript files and 15 Excel files that contains the code for each source and destination folder which i believe is not efficient way. I have tried a lot to add multiple source and destination folder options in the below mentioned code(s) but i am not successful, can anyone help me, i will be thankful.
the below mentioned code is VBscript
Dim oExcel, strWB, nameWB, wb
strWB = "E:\Delta\Folder monitor.xlsm"
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "E:\\\\Delta\\\\Source" 'use here your path
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
' msgbox "OK"
'MsgBox "A new file was just created: " & _
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
'// Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile,Now)
End Select
Loop
and the second code for this purpose should be copied in a standard module:
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private Const fromPath As String = "E:\Delta\Source\"
Sub startMonitoring()
Dim strVBSPath As String
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
TerminateMonintoringScript 'to terminate monitoring script, if running..
Shell "cmd.exe /c """ & strVBSPath & """", 0
End Sub
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg
As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
Application.OnTime CDate(arr(1)) + TimeValue("00:01:00"), "'DoSomething """ & CStr(arr(0)) & """'"
Debug.Print "start " & Now 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(strFileName As String)
Const toPath As String = "E:\Delta\Destination\"
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
you can see the previous query here on the link Previous Query
Please, use the next scenario. It assumes that you will fill the necessary path in an existing Excel sheet. Since, it will take the necessary paths based on a cell selection, it is necessary to name the sheet in discussion as "Folders". In Column A:A you should fill the 'Source' folder path (ending in backslash "") and in B:B, the 'Destination' folder path (also ending in backslash).
The proposed solution takes the necessary paths based on your selection in A:A column. The 'Destination' path is extracted based on the selection row.
Please, replace the existing string with the next one, adapting the two necessary paths:
Dim oExcel, strWB, nameWB, wb
strWB = "C:\Teste VBA Excel\Folder monitor.xlsm" 'use here your workbook path!!!
nameWB = Left(strWB, InStr(StrReverse(strWB), "\") - 1)
nameWB = Right(strWB, Len(nameWB))
Set objExcel = GetObject(,"Excel.Application")
Set wb = objExcel.Workbooks(nameWB)
if wb is nothing then wbscript.quit 'the necessary workbook is not open...
dim strComputer, strDirToMonitor, strTime, objWMIService, colMonitoredEvents, objEventObject, MyFile
strComputer = "."
'# WMI needs two backslashes (\\) as path separator and each of it should be excaped.
'# So, you must use 4 backslashes (\\\\) as path separator!
strDirToMonitor = "C:\\\\test\\\\test" 'use here your path !!!
'# Monitor Above every 10 secs...
strTime = "10"
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery _
("SELECT * FROM __InstanceOperationEvent WITHIN " & strTime & " WHERE " _
& "Targetinstance ISA 'CIM_DirectoryContainsFile' and " _
& "TargetInstance.GroupComponent= " _
& "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")' and " _
' & "'Win32_Directory.Name=" & Chr(34) & strDirToMonitor & Chr(34) & "'")
Do While True
Set objEventObject = colMonitoredEvents.NextEvent()
Select Case objEventObject.Path_.Class
Case "__InstanceCreationEvent"
MyFile = StrReverse(objEventObject.TargetInstance.PartComponent)
' Get the string to the left of the first \ and reverse it
MyFile = (StrReverse(Left(MyFile, InStr(MyFile, "\") - 1)))
MyFile = Mid(MyFile, 1, Len(MyFile) - 1)
'send the information to the waiting workbook:
objExcel.Application.Run "'" & strWB & "'!GetMonitorInformation", Array(MyFile, Now, strDirToMonitor)
End Select
Loop
The adapted script sends also the source path to the waiting workbook...
TerminateMonintoringScript Sub remains exactly as it is.
Please, copy the next adapted code instead of existing one, in the used standard module (TerminateMonintoringScript included, even not modified):
Option Explicit
Private Const ourScript As String = "FolderMonitor.vbs"
Private fromPath As String, toPath As String
Sub startMonitoring()
Dim strVBSPath As String, actCell As Range, strTxt As String, pos As Long, endP As Long, oldPath As String
Set actCell = ActiveCell
If actCell.Parent.Name <> "Folders" Then MsgBox "Wrong activated sheet...": Exit Sub
fromPath = actCell.Value
If actCell.Column <> 1 Or Dir(fromPath, vbDirectory) = "" Then Exit Sub 'not a valid path in the selected cell
strVBSPath = ThisWorkbook.Path & "\VBScript\" & ourScript
'change the script necessary "strDirToMonitor" variable path, if the case:__________________________
strTxt = ReadFile(strVBSPath)
pos = InStr(strTxt, Replace(fromPath, "\", "\\\\"))
If pos = 0 Then 'if not the correct path already exists
pos = InStr(strTxt, "strDirToMonitor = """) 'start position of the existing path
endP = InStr(strTxt, """ 'use here your path") 'end position of the existing path
'extract existing path:
oldPath = Mid(strTxt, pos + Len("strDirToMonitor = """), endP - (pos + Len("strDirToMonitor = """)))
strTxt = Replace(strTxt, oldPath, _
Replace(Left(fromPath, Len(fromPath) - 1), "\", "\\\\")) 'replacing existing with the new one
'drop back the updated string in the vbs file:
Dim iFileNum As Long: iFileNum = FreeFile
Open strVBSPath For Output As iFileNum
Print #iFileNum, strTxt
Close iFileNum
End If
'__________________________________________________________________________________________________
TerminateMonintoringScript 'to terminate monitoring script, if running...
Application.Wait Now + TimeValue("00:00:02") 'to be sure that the next line will load the updated file...
Shell "cmd.exe /c """ & strVBSPath & """", 0 'run the VBScript
End Sub
Function ReadFile(strFile As String) As String 'function to read the vbscript string content
Dim iTxtFile As Integer
iTxtFile = FreeFile
Open strFile For Input As iTxtFile
ReadFile = Input(LOF(iTxtFile), iTxtFile)
Close iTxtFile
End Function
Sub TerminateMonintoringScript()
Dim objWMIService As Object, colItems As Object, objItem As Object, Msg As String
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", "WQL", 48)
For Each objItem In colItems
If objItem.Caption = "wscript.exe" Then
'// msg Contains the path of the exercutable script and the script name
On Error Resume Next
Msg = objItem.CommandLine 'for the case of null
On Error GoTo 0
'// If wbscript.exe runs the monitoring script:
If InStr(1, Msg, ourScript) > 0 Then
Debug.Print "Terminate Wscript process..."
objItem.Terminate 'terminate process
End If
End If
Next
Set objWMIService = Nothing: Set colItems = Nothing
End Sub
Sub GetMonitorInformation(arr As Variant)
'call DoSomething Sub after 2 hours (now IT WILL RUN AFTER 1 MINUTE, for testing reasons...)
'for running after 2 hours you should change "00:01:00" in "02:00:00":
arr(0) = Replace(arr(0), "'", "''") 'escape simple quote (') character'
fromPath = Replace(arr(2), "\\\\", "\")
Dim rngFrom As Range: Set rngFrom = ThisWorkbook.Sheets("Folders").Range("A:A").Find(what:=fromPath)
toPath = rngFrom.Offset(, 1).Value
Application.OnTime CDate(arr(1)) + TimeValue("00:00:30"), "'DoSomething """ & fromPath & "\" & CStr(arr(0)) & """, """ & toPath & CStr(arr(0)) & """'"
Debug.Print Now; " start " & arr(0) & fromPath & "\" & CStr(arr(0)) 'just for testing (wait a minute...)
'finaly, this line should be commented.
End Sub
Sub DoSomething(sourceFileName As String, destFilename As String)
If Dir(destFilename) = "" Then
Name sourceFileName As destFilename
Debug.Print sourceFileName & " moved to " & destFilename 'just for testing...
Else
Debug.Print "File """ & destFilename & """ already exists in this location..."
End If
End Sub
Sub DoSomething_(strFileName As String) 'cancelled
If Dir(toPath & strFileName) = "" Then
Name fromPath & strFileName As toPath & strFileName
Debug.Print strFileName & " moved from " & fromPath & " to " & toPath 'just for testing...
Else
MsgBox "File """ & toPath & strFileName & """ already exists in this location..."
End If
End Sub
So, you only need to replace the existing VBA code with the above adapted one, to place the 'source'/'destination' paths in columns A:B of one of Excel sheets, which to be named "Folders".
Select in column A:A a 'Source' cell and run startMonitoring.
Play with files creation and check their moving from the new 'source' to the new 'destination'...
But you have to understand that only a session of the WMI class can run at a specific moment. This means that you cannot simultaneously monitor more than one folder...
I am still documenting regarding the possibility to use a query able to be common for multiple folders. But I never could see such an approach till now and it may not be possible...
I need to export in a .txt file that contains all the titles, numbers and comments of a PowerPoint with VBA. I found some code that allows me to do it, however I can't add the code to display the title.
I tried to use ActivePresentation.Slides(1).CustomLayout.name but it only shows me the name of slide 1. What I need is to display a dynamic title.
Dim oSl As Slide
Dim oSlides As Slides
Dim oCom As Comment
Dim sText As String
Dim sFilename As String
Set oSlides = ActivePresentation.Slides
For Each oSl In oSlides
sText = sText & vbCrLf & "==================================" & vbCrLf
sText = sText & "Slide: " & oSl.SlideIndex & vbCrLf
sText = sText & "==================================" & vbCrLf
For Each oCom In oSl.Comments
sText = sText & oCom.Text & vbCrLf
sText = sText & "--------------" & vbCrLf
Next oCom
Next oSl
sFilename = ActivePresentation.Path & "\" & "Titles-Comments" & ".txt"
If Len(sFilename) > 0 Then
WriteStringToFile sFilename, sText
SendFileToNotePad sFilename
End If
I'm trying to copy all slides (preserving format) from an open presentation to a new one (except slide 2). I've got a block of code that seems to work if I step through it, but when I run it in presentation mode (or using Alt+F8), only the last slide is copied to the new presentation the same number of times as there are original presentation slides.
Can anyone spot what I'm doing wrong? Thanks for your help!
Public Sub SaveAs()
Dim oldPresentation As Presentation, newPresentation As Presentation
Dim oldSlide As Slide
Dim i As Integer, count As Integer, path As String, newFileName As String
path = ActivePresentation.path
count = ActivePresentation.Slides.count
Set oldPresentation = ActivePresentation
Set newPresentation = Application.Presentations.Add
For i = 1 To count
If i <> 2 Then
Set oldSlide = oldPresentation.Slides(i)
oldSlide.Copy
newPresentation.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
End If
Next i
newFileName = "\Test " & Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") & ".pptx"
newFileName = Replace(newFileName, ":", "-")
With newPresentation
.SaveCopyAs fileName:=path & newFileName, FileFormat:=ppSaveAsOpenXMLPresentation
End With
newPresentation.Close
End Sub
I found sort of silly solution. I save the current deck to a new copy, then just delete slide 2. Not sure if this is a preferred method or not.
Public Sub SaveAs()
Dim oldPresentation As Presentation
Dim newDeck As Presentation
Dim path As String, newFileName As String
path = ActivePresentation.path
Set oldPresentation = ActivePresentation
newFileName = "\HRB " & Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") & ".pptx"
newFileName = Replace(newFileName, ":", "-")
With oldPresentation
.SaveCopyAs fileName:=path & newFileName, FileFormat:=ppSaveAsOpenXMLPresentation
End With
Set newDeck = GetObject(path & newFileName)
newDeck.Slides(2).Delete
newDeck.Save
newDeck.Close
End Sub
I'm trying to test if a cell in a closed external workbook is N/A. In the code below, cell "G5" in the referenced workbook is definitely N/A, but when referencing it using the IsNA function below it returns "Good to go!" when the intention is for it to return "Hay!" in the message box.
Sub TestTest()
'Declaring variables [BD]
Dim sFilePath As String
Dim sFileName As String
Dim sSourceSheet As String
Dim sSourceCell As String
sFileName = "0306-0312 Margin Master.xlsx"
sFilePath = "\\store\GroupDrives\Pricing\_Deli_\Deli Fresh Shift\Margin Master\"
sSourceSheet = "Bakery"
sSourceCell = "G5"
If Application.WorksheetFunction.IsNA("'" & sFilePath & "[" & sFileName & "]" & sSourceSheet & "'!" & _
Range("A1").Range(sSourceCell).Address(, , xlR1C1)) Then
MsgBox "Hay!"
Else
MsgBox "Good to go!"
End If
End Sub
Try using ExecuteExcel4Macro:
Sub TestTest()
'Declaring variables [BD]
Dim sFilePath As String
Dim sFileName As String
Dim sSourceSheet As String
Dim sSourceCell As String
dim externalValue As Variant
sFileName = "0306-0312 Margin Master.xlsx"
sFilePath = "\\store\GroupDrives\Pricing\_Deli_\Deli Fresh Shift\Margin Master\"
sSourceSheet = "Bakery"
sSourceCell = "G5"
externalValue = ExecuteExcel4Macro("'" & sFilePath & "[" & sFileName & "]" & sSourceSheet & "'!" & _
Range("A1").Range(sSourceCell).Address(, , xlR1C1))
If Application.IsNa(externalValue) Then
MsgBox "Hay!"
ElseIf IsError(externalValue) Then
MsgBox "May not work"
Else
MsgBox "Good to go! (value is '" & externalValue & "')"
End If
End Sub
Note: Range("A1").Range(sSourceCell).Address(, , xlR1C1) can probably be abbreviated to Range(sSourceCell).Address(, , xlR1C1) if you are just using cell references such as "G5" as the values of sSourceCell.
An alternative may be to use Evaluate() with a "regular formula", i.e.
Sub TestTest()
'Declaring variables [BD]
Dim sFilePath As String, sFileName As String, sSourceSheet As String, sSourceCell As String
sFileName = "0306-0312 Margin Master.xlsx"
sFilePath = "\\store\GroupDrives\Pricing\_Deli_\Deli Fresh Shift\Margin Master\"
sSourceSheet = "Bakery"
sSourceCell = "R5C7"
If Application.WorksheetFunction.IsError(Evaluate("=('" & sFilePath & "[" & sFileName & "]" & sSourceSheet & "'!" & sSourceCell & ")")) Then
MsgBox "Hay!"
Else
MsgBox "Good to go!"
End If
End Sub
It should work for you if the cell is truly an #N/A error. If it's just a string that's #N/A, you can just tweak that If statement to check evaluate the cell value.
Note: The Cell Reference needs to be R1C1 style, I believe.
I have searched for a method to save current slide as a picture in Slideshow mode, when pressing an action button on the slide. This is what I came up with in the end:
`Sub SaveCurrentSlideAsJpg()`
Dim imagePath As String
Dim slideNum As Integer
imagePath = "C:\Users\XXXXX\Pictures\Slides\"
slideNum = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
' first check if this already exists then delete it
If Dir(imagePath & ActivePresentation.Name & "_" & slideNum & ".jpg") <> ""
Then
Kill imagePath & ActivePresentation.Name & "_" & slideNum & ".jpg"
End If
' now save the slide
ActivePresentation.SlideShowWindow.View.Slide.Export _
FileName:=imagePath & ActivePresentation.Name & "_" & slideNum & ".jpg", _
FilterName:="JPG"
End Sub
This is fine except that it saves to a default location on my PC. I will be giving this to other people and I need a dialog that pops up every time they try to save asking them where to save. All my attempts incorporate the Saveas dialog were unsuccessful. I would appreciate if anyone could help me with this. Thanks
You can use this function to select a folder:
Function BrowseForFolder(dialogTitle As String) As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = dialogTitle
.Show
If .SelectedItems.Count = 0 Then
' Browsing cancelled by user.
BrowseForFolder = ""
Else
BrowseForFolder = .SelectedItems.Item(1)
End If
End With
End Function
So instead of hard-coding imagePath, you would do this:
imagePath = BrowseForFolder("Save image in this folder...")