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 have written on Outlook VBScript which downloads the attachment from Outlook. But now I am encountering an error
Remote Server machine does not exist or is unavailable
I get this error a few time and also sometimes this code runs without any error. I was able to track the exact point of failure. The line is
Set olns = olApp.GetNameSpace("MAPI")
I have almost tried everything yet I am not able to to find the solution.
Set Arg = WScript.Arguments
Dim item1
Dim objsubject
Dim intcount
Dim i
Dim savename
Dim vTextFile
Dim filename
Dim extension
Dim t
Dim Itimestamp
Dim savefolder
Dim vSenderEmailAddress
Dim vFlagTextFileCreate
vFlagTextFileCreate = True
savefolder = "C:\Users\SANxSAxAABOTDEV\Documents\Automation Anywhere Files\Automation Anywhere\My Tasks\ThrdOutlookTest"
vTextFile = savefolder & "\File Report.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then 'Could not get instance of Outlook, so create a new one
Err.Clear
Set olApp = CreateObject("Outlook.Application")
End If
On Error Goto 0
Set olns = olApp.GetNameSpace("MAPI")
olns.Logon "Outlook", , False, True
Set objFolder = olns.GetDefaultFolder(6)
'objFolder.InAppFolderSyncObject = True
'syc.Start
For Each item1 In objFolder.Items
If item1.Unread = True Then
objsubject = item1.Subject
If InStr(UCase(objsubject) ,"RPA BOT") Then
intCount = item1.Attachments.Count
If intcount > 0 Then
For i = 1 To intcount
If InStr(item1.Attachments(i).filename, ".xls") Then
t = Now()
'Adding timestamp to the file to make it unique
Itimestamp = Right("0" & Hour(t), 2) & _
Right("0" & Minute(t), 2) & _
Right("0" & Second(t), 2)
fileName = Left(item1.Attachments(i).filename, InStr(item1.Attachments(i).filename, ".xl") - 1)
extension = Right(item1.Attachments(i).filename, Len(item1.Attachments(i).filename) - InStr(item1.Attachments(i).filename, ".xl"))
savename = saveFolder & "\" & fileName & "_" & Itimestamp & "." & extension
item1.Attachments(i).SaveAsFile savename
WScript.Sleep 1000
If item1.SenderEmailType = "SMTP" Then
vSenderEmailAddress = item1.SenderEmailAddress
ElseIf item1.SenderEmailType = "EX" Then
vSenderEmailAddress = item1.Sender.GetExchangeUser.PrimarySmtpAddress
End If 'If item1.SenderEmailType
'Create InfoFile If does not exist
If vFlagTextFileCreate = True Then
vFlagTextFileCreate = False
fso.CreateTextFile vTextFile
End If
Set ts = fso.OpenTextFile(vTextFile, 8, True, 0)
ts.WriteLine fileName & "_" & Itimestamp & "." & extension & "|" & item1.Subject & "|" & vSenderEmailAddress & vbLf
ts.Close
End If 'If InStr(item1.Attachments(i).filename
Next
'Turning the unread mail to read
item1.Unread = False
End If 'If intcount > 0 Then
End If 'If Instr(objsubject ,
End If 'If item1.Unread=True
Next
olns.Logoff
Set olns = Nothing
Set olApp = Nothing
WScript.Quit
I did some research and came to know that this issue may be caused due to the fact that the outlook session is already opened before running the script. So I added a patch before Set fso = CreateObject("Scripting.FileSystemObject") to kill all the outlook.exe session. I did not get any error for a while. I don't know if this is correct. I would be happy to know your feedback on this.
Killing the outlook.exe session before I create the object for Outlook.Application solved my error. I added a patch before Set fso = CreateObject("Scripting.FileSystemObject") to kill outlook.exe sessions. Below is the patch
strComputer = "."
Set Arg = WScript.Arguments
Process = "outlook.exe"
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcess = objWMIService.ExecQuery ("Select * from Win32_Process Where Name like '" & Process & "%'")
For Each p in colProcess
On Error Resume Next
p.Terminate
On Error GoTo 0
Next
SET objWMIService = Nothing
SET colProcess = Nothing
Here is my problem:
Duplicate versions
I checked the version history on the Sharepoint site and it doesn't show any duplicates.
Here is the code im using:
Sub versionhistory()
'
' versionhistory Macro
On Error Resume Next
' On Error GoTo message
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim strVersionInfo As String
Set dlvVersions = ThisDocument.DocumentLibraryVersions
'MsgBox ActiveDocument.Bookmarks.Count
Dim tbl As Word.Table
'Set tbl = ActiveDocument.Tables.Item(2)
Set tbl = ActiveDocument.Bookmarks("VersionTable").Range.Tables(1)
If dlvVersions.IsVersioningEnabled Then
strVersionInfo = "This document has " & dlvVersions.Count & " versions: " & vbCrLf
Call InsertVersionHistory(tbl, dlvVersions)
For Each dlvVersion In dlvVersions
strVersionInfo = strVersionInfo & _
" - Version #: " & dlvVersion.Index & vbCrLf & _
" - Modified by: " & dlvVersion.ModifiedBy & vbCrLf & _
" - Modified on: " & dlvVersion.Modified & vbCrLf & _
" - Comments: " & dlvVersion.Comments & vbCrLf
Next
Else
strVersionInfo = "Versioning not enabled for this document."
End If
'MsgBox strVersionInfo, vbInformation + vbOKOnly, "Version Information"
Set dlvVersion = Nothing
Set dlvVersions = Nothing
Call GetUserName
'message:
'MsgBox Err.Description
MsgBox ("Insert Version Number in the Header and type a Title in the [Insert Title here] on the front page. It will be automatically updated in the footer." & vbNewLine & vbNewLine & "Do Not Type in the Review and Version tables.")
End Sub
Private Function InsertVersionHistory(oVerTbl As Word.Table, oVersions As Office.DocumentLibraryVersions)
Dim rowIndex As Integer
Dim oVersion As Office.DocumentLibraryVersion
Dim oNewRow As Row
'test
Dim versionIndex As Integer
For rowIndex = 2 To oVerTbl.Rows.Count
oVerTbl.Rows.Item(2).Delete
Next rowIndex
rowIndex = 1
'test
versionIndex = oVersions.Count
For Each oVersion In oVersions
If (rowIndex > 5) Then
Return
End If
rowIndex = rowIndex + 1
oVerTbl.Rows.Add
Set oNewRow = oVerTbl.Rows(oVerTbl.Rows.Count)
oNewRow.Shading.BackgroundPatternColor = wdColorWhite
oNewRow.Range.Font.TextColor = wdBlack
oNewRow.Range.Font.Name = "Tahoma"
oNewRow.Range.Font.Bold = False
oNewRow.Range.Font.Size = 12
oNewRow.Range.ParagraphFormat.SpaceAfter = 4
With oNewRow.Cells(1)
'.Range.Text = oVersion.Index
.Range.Text = versionIndex
End With
With oNewRow.Cells(2)
.Range.Text = FormUserFullName(GetUserFullName(oVersion.ModifiedBy))
End With
With oNewRow.Cells(3)
.Range.Text = oVersion.Modified
End With
With oNewRow.Cells(4)
.Range.Text = oVersion.Comments
End With
versionIndex = versionIndex - 1
Next
Set oVersion = Nothing
End Function
Function GetUserFullName(userName As String) As String
Dim WSHnet, UserDomain, objUser
Set WSHnet = CreateObject("WScript.Network")
'UserDomain = WSHnet.UserDomain
'Set objUser = GetObject("WinNT://" & UserDomain & "/" & userName & ",user")
userName = Replace(userName, "\", "/")
Set objUser = GetObject("WinNT://" & userName & ",user")
'MsgBox objUser.FullName
GetUserFullName = objUser.FullName
End Function
Function FormUserFullName(userName As String) As String
Dim arrUserName As Variant
Dim changedUserName As String
arrUserName = Split(userName, ",")
Dim length As Integer
length = UBound(arrUserName) - LBound(arrUserName) + 1
If length >= 2 Then
changedUserName = arrUserName(1) & " " & arrUserName(0)
Else
changedUserName = userName
End If
FormUserFullName = changedUserName
End Function
Private Function GetUserName()
Dim userName As String
userName = ActiveDocument.BuiltInDocumentProperties("Author")
ActiveDocument.BuiltInDocumentProperties("Author") = FormUserFullName(userName)
End Function
I know this is old, but I was looking for the same thing and found this article. I'm still trying it out, but wanted to share before I got distracted with my real job.
From: SixSigmaGuy on microsoft.public.sharepoint.development-and-programming.narkive.com/...
Wanted to share my findings, so far. Surprisingly, I could not find
anything in the SharePoint Designer object/class that supported versions,
but the Office, Word, Excel, and PowerPoint objects do support it.. It
wasn't easy to find, but once I found it, it works great, as long as the
file in the document library is one of the Office documents.
Here's some sample code, written in Excel VBA, showing how to get the
version information for a paritcular SharePoint Document Library file
created in Excel:
Public viRow As Long
Function fCheckVersions(stFilename As String) As Boolean
' stFilename is the full URL to a document in a Document Library.
'
Dim wb As Excel.Workbook
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim stExtension As String
Dim iPosExt As Long
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 1) = stFilename
If Workbooks.CanCheckOut(stFilename) = True Then
Set wb = Workbooks.Open(stFilename, , True)
Set dlvVersions = wb.DocumentLibraryVersions
If dlvVersions.IsVersioningEnabled = True Then
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 3) = "Num
Versions = " & dlvVersions.Count
For Each dlvVersion In dlvVersions
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 4) = "Version: " & dlvVersion.Index
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 5) = "Modified Date: " & dlvVersion.Modified
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 6) = "Modified by: " & dlvVersion.ModifiedBy
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 7) = "Comments: " & dlvVersion.Comments
viRow = viRow + 1
Next dlvVersion
End If
wb.Close False
End If
Set wb = Nothing
DoEvents
End Function`
Fortunately, I discovered that Excel can open non-Excel files in most
cases. I.e., I can, for example, open a jpg file in Excel and use the
dlvVersions collection for that file.
I am trying to make the below output into a text file on my desktop. I am very new (as in today) and I found the below script online, I have gotten my head around what each but does however I am struggling to make it output as a text file. I am not sure where the commands should go (beginning middle or end?) to do this. I have found one command but I am getting errors left right and centre. Please help.
Sub CountItemsInMBX()
Dim outapp As Outlook.Application
Set outapp = CreateObject("Outlook.Application")
Dim olns As Outlook.NameSpace
Set olns = outapp.GetNamespace("MAPI")
Debug.Print GetSubFolderCount(olns.GetDefaultFolder(olFolderInbox).Parent)
End Sub
Function GetSubFolderCount(objParentFolder As MAPIFolder) As Long
Dim currentFolders As Folders
Dim fldCurrent As MAPIFolder
Set currentFolders = objParentFolder.Folders
If currentFolders.Count > 0 Then
Set fldCurrent = currentFolders.GetFirst
While Not fldCurrent Is Nothing
TempFolderCount = TempFolderCount + GetSubFolderCount(fldCurrent)
Set fldCurrent = currentFolders.GetNext
Wend
Debug.Print objParentFolder.Name & " - " & objParentFolder.Items.Count
GetSubFolderCount = TempFolderCount + objParentFolder.Items.Count
Else
Debug.Print objParentFolder.Name & " - " & objParentFolder.Items.Count
GetSubFolderCount = objParentFolder.Items.Count
End If
End Function
The following is your code, converted to call a function, passing it a string, that will write to a text file. Change the file path & name to suit your needs.
Personally, I don't like the call method because it is a waste to check if the file exists, etc. for every call. However, since your code had two subroutines that need to write text, I was too lazy to embed the proper code in your code. You could either leave as is (if seldom used), or combine together if desired.
Option Explicit
Sub CountItemsInMBX()
Dim outapp As Outlook.Application
Dim olns As Outlook.NameSpace
Set outapp = CreateObject("Outlook.Application")
Set olns = outapp.GetNamespace("MAPI")
'Debug.Print GetSubFolderCount(olns.GetDefaultFolder(olFolderInbox).Parent)
Write_To_MyLog GetSubFolderCount(olns.GetDefaultFolder(olFolderInbox).Parent)
End Sub
Function GetSubFolderCount(objParentFolder As MAPIFolder) As Long
Dim currentFolders As Folders
Dim fldCurrent As MAPIFolder
Dim TempFolderCount As Integer
Set currentFolders = objParentFolder.Folders
If currentFolders.Count > 0 Then
Set fldCurrent = currentFolders.GetFirst
While Not fldCurrent Is Nothing
TempFolderCount = TempFolderCount + GetSubFolderCount(fldCurrent)
Set fldCurrent = currentFolders.GetNext
Wend
'Debug.Print objParentFolder.Name & " - " & objParentFolder.Items.Count
Write_To_MyLog objParentFolder.Name & " - " & objParentFolder.Items.Count
GetSubFolderCount = TempFolderCount + objParentFolder.Items.Count
Else
'Debug.Print objParentFolder.Name & " - " & objParentFolder.Items.Count
Write_To_MyLog objParentFolder.Name & " - " & objParentFolder.Items.Count
GetSubFolderCount = objParentFolder.Items.Count
End If
End Function
Public Function Write_To_MyLog(sText As String)
Dim oFSO As FileSystemObject
Dim oFile As File
Dim oStream As TextStream
On Error GoTo Error_trap
Set oFSO = New FileSystemObject
If Not oFSO.FileExists("C:\Temp\Outlook_Folders.txt") Then
Set oStream = oFSO.CreateTextFile("C:\Temp\Outlook_Folders.txt")
oStream.WriteLine " "
Else
Set oFile = oFSO.GetFile("C:\Temp\Outlook_Folders.txt")
Set oStream = oFile.OpenAsTextStream(ForAppending, TristateMixed)
End If
oStream.WriteLine sText
oStream.Close
Set oStream = Nothing
Set oFile = Nothing
Set oFSO = Nothing
Early_Exit:
Exit Function
Error_trap:
Dim strError As String
strError = "In subroutine: Write_To_MyLog " & vbCrLf & _
Err.Number & vbCrLf & vbCrLf & Err.Description & vbCrLf & _
"At Line: " & Erl
Err.Source = "Module_Utilities: Write_To_MyLog at Line: " & Erl
MsgBox "Error: " & strError
'Write_To_Log strError ' This is a call to a function that saves the error info to a database table.
Resume Early_Exit
Resume Next
End Function
I have a vba macro to un-merge the merged cells and repeat in excel, but i need to run this macro without opening the excel and also the same logic will be applied to multiple excels so i need a batch file which calls the vba and apply to the excel in a folder. Is there any way to do it.?
You can call this VBscript from a batch file (in a loop)
Usage:
CScript inject.vbs "C:\johan\VbaStuff\Empty workbook.xlsx" "C:
\johan\VbaStuff\DummyMacro.bas" "AddDateToA1"
inject.vbs:
dim oArgs, i, FSO
dim fileName, macroFileName, functionName
dim oApplication, oWorkbooks, oWorkbook, oVbProject
dim oComponents, oModule, fullFunction
Set oArgs = WScript.Arguments
For i = 0 to oArgs.Count - 1
WScript.Echo "Arg" & i & ": " & oArgs(i)
Next
WScript.Echo ""
if oArgs.Count < 3 then
WScript.Echo "Too few arguments"
WScript.Quit
end if
fileName = oArgs(0)
macroFileName = oArgs(1)
functionName = oArgs(2)
set FSO = CreateObject("Scripting.FileSystemObject")
if not FSO.FileExists(fileName) then
WScript.Echo "Excel file does not exist"
WScript.Quit
end if
if not FSO.FileExists(macroFileName) then
WScript.Echo "Macro file does not exist"
WScript.Quit
end if
set oApplication = CreateObject("Excel.Application")
oApplication.DisplayAlerts = False
WScript.Echo "Injecting in Excel version: " & oApplication.Version
set oWorkbooks = oApplication.Workbooks
set oWorkbook = oWorkbooks.Open(fileName)
WScript.Echo oWorkbook.Name
set oVbProject = oWorkbook.VBProject
WScript.Echo oVbProject.Name
set oComponents = oVbProject.VBComponents
set oModule = oComponents.Import(macroFileName)
fullFunction = Trim(oModule.Name & "." & functionName)
WScript.Echo "Full function: '" & fullFunction & "'"
oApplication.Run(fullFunction)
oComponents.Remove(oModule)
oWorkbook.Save()
WScript.Echo "Saved changes"
oWorkbook.Close(False)
Call oApplication.Quit()
set oModule = Nothing
set oComponents = Nothing
set oVbProject = Nothing
set oWorkbook = Nothing
set oWorkbooks = Nothing
set oApplication = Nothing
set FSO = Nothing
Dummy macro for completeness:
Attribute VB_Name = "DummyMacro"
Sub AddDateToA1()
Dim oCell As Range
Dim sTime As String
Set oCell = ThisWorkbook.Sheets(1).Cells(1, 1)
sTime = CStr(TimeValue(Now))
oCell.Value = sTime
MsgBox "Wrote time " & sTime & " to " & oCell.Address(0, 0, xlA1, 1)
End Sub