I have created a little program to search a set of folders holding documents scanned.
the folder structure is as follows:
c:\images\year\month\date\documenttype\firstpartofdocumentNo.\
the year folder contains years from 2005 - 2015
the month folder contains the months of the year (Obviously)
same with date
the documenttype folder can contain between 1 and 5 folders
the firstpartofdocumentno. can contain between 1 and 3 folders
the code I am using at the moment is :
CompName = Environment.MachineName
'MsgBox(CompName)
TicketNo = TxtTicketNo.Text
If CompName = "Comp1" Then
ImageDir = "C:\Images\"
Else
ImageDir = "\\Comp1\Images\"
End If
For Each DirYear As String In Directory.GetDirectories(ImageDir)
Dim YearInfo As New DirectoryInfo(DirYear)
For Each DirMonth As String In Directory.GetDirectories(DirYear)
Dim MonthInfo As New DirectoryInfo(DirMonth)
For Each DirDate As String In Directory.GetDirectories(DirMonth)
Dim DateInfo As New DirectoryInfo(DirDate)
For Each DirType As String In Directory.GetDirectories(DirDate)
Dim TypeInfo As New DirectoryInfo(DirType)
For Each DirStart As String In Directory.GetDirectories(DirType)
Dim StartInfo As New DirectoryInfo(DirStart)
MainDirectory = ImageDir & YearInfo.Name & "\" & MonthInfo.Name & "\" & DateInfo.Name & "\" & TypeInfo.Name & "\" & StartInfo.Name & "\"
'LstFiles.Items.Add(YearInfo.Name & "\" & MonthInfo.Name & "\" & DateInfo.Name & "\" & TypeInfo.Name & "\")
'Dim files() As String = Directory.GetFiles(MainDirectory, TicketNo & "*")
'For Each Ticket As String In Directory.GetFiles(MainDirectory, TicketNo)
For Each Ticket As String In Directory.GetFiles(MainDirectory, TicketNo & "*")
LstFiles.Items.Add(Ticket)
Next
'Next
Next
'MsgBox(files)
'LstFiles.Items.Add()
Next
'LstFiles.Items.Add(dirInfo.Name)
Next
Next
'MsgBox(ImageDir)
Next
I have a textbox on the form which is used to enter the last four numbers of the ticketno and then this code runs when the button is clicked.
The problem is it can take up to five minutes to search, so I was wondering if there is a way to optimize this code to speed it up a bit or does this sound about right for searching that many folders.
Thanks in advance
Gareth
Related
I often need a search for all emails of a specific day. In order not to change the criteria of a search folder every time, I wrote a macro which creates a suitable search folder after asking for a date and displaying this folder.
Works fine, but whereas the search folder created the manual way within Outlook only lists the mails of this day, the programmed version also displays appointments of calendars of colleagues who shared their calendars with me - appointments and meetings which don't relate to me at all but were sent on that specific day.
The second thing, but a not important one is, that when displaying the properties of the created folder in Outlook the button for changing the criteria is disabled.
I think I need some additional filter criteria for method AdvancedSearch, but which ones?
At the moment, my code is as follows:
Sub CreateSearchFolderForDate()
'Creates a search folder for a specific date. Only the primarey exchange mailbox will be considered
'(no offline folders, no shared folders).
'The folder is displayed afterwards
Dim oSearch As Search
Dim oSearchFolder As Object
Dim strScope As String
Dim strFilter As String
Dim strDate1 As String
Dim strDate2 As String
Dim strInput As String
varInput = InputBox("Date?", "Create search order for a specific date", Date)
If Not IsDate(varInput) Then
Exit Sub
End If
'Delete existing folder first, otherwise there is a runtime error
Set oSearchFolder = GetSearchFolderByName("Mails for day X")
If Not oSearchFolder Is Nothing Then
oSearchFolder.Delete
End If
strScope = "'" & Application.Session.GetDefaultFolder(olFolderInbox).Parent.FolderPath & "'"
strFilter = "urn:schemas:mailheader:date >= '" & CDate(varInput) & "' AND urn:schemas:mailheader:date < '" & CDate(varInput) + 1 & "'"
Set oSearch = Application.AdvancedSearch(Scope:=strScope, Filter:=strFilter, SearchSubFolders:=True, Tag:="Mails of a specific date")
oSearch.Save ("Mails for day X")
Set oSearchFolder = GetSearchFolderByName("Mails for day X")
oSearchFolder.Display
End Sub
Function GetSearchFolderByName(strSearchFolderName As String) As Object
'Returns the search folder with the display name specified. Only the primarey exchange mailbox will be considered
'(no offline folders, no shared folders).
Dim oStore As Outlook.Store
Dim oFolder As Outlook.folder
On Error Resume Next
Set GetSearchFolderByName = Nothing
For Each oStore In Application.Session.Stores
If oStore.ExchangeStoreType = olPrimaryExchangeMailbox Then
For Each oFolder In oStore.GetSearchFolders
If oFolder.Name = strSearchFolderName Then
Set GetSearchFolderByName = oFolder
Exit Function
End If
Next
End If
Next
End Function
My idea was to use '''urn:schemas:calendar:dtstart'' as additional AND as for "normal" emails that should be empty and messed around a little bit with it - but either it had no effect or it resulted in a list containing only the undesired elements and no "normal" mails at all.
Attempts like IS NULL or IS NOT NULL in the filter caused VBA runtime errors.
In column "folder" the created search folder displays either the folder/subfolder my mails are stored in or for the unwanted entries a certain common part like Doe, Jane common_part and Doe, John common_part. But I didn't find a property which I could use as part of my filter ('''AND property NOT LIKE %common_part%''').
Any hint would be very much appreciated.
Regards,
Bootes
Update 2023-02-08: Before refactoring my problem using the hints and answers by #niton (thanks a lot for the patience) I will start a few more trys with AdvancedSearch, based on an analysis of a manually created search folder using the Redemption-Tool as developed by #Dmitry Streblechenko and described in his posting in How to get a search folder criteria in Outlook. The tool provided the following SQL-Statement:
((NOT (MessageClass LIKE 'IPM.Appointment%')) AND (NOT (MessageClass LIKE 'IPM.Contact%')) AND (NOT (MessageClass LIKE 'IPM.DistList%')) AND
(NOT (MessageClass LIKE 'IPM.Activity%')) AND
(NOT (MessageClass LIKE 'IPM.StickyNote%')) AND (NOT (MessageClass = 'IPM.Task'))
AND (NOT (MessageClass LIKE 'IPM.Task.%'))) AND
((("http://schemas.microsoft.com/mapi/proptag/0x0E090102" <> EF0000004B1E3AD5164F3F459BFE6A913D00E89042800000')
AND ("http://schemas.microsoft.com/mapi/proptag/0x0E090102" <> EF0000004B1E3AD5164F3F459BFE6A913D00E89022800000'))
AND ((SentOn < '2022-12-20') AND (SentOn >= '2022-12-19')))
I tried to translate this into VBA, but had no real success: If I use just the active lines, there is no effect at all, if I add the last two ones (formatted as comments below), I get error "Runtime error -2147023281 (8007064f) - Error during execution of operation" (re-translated from German to English):
strF = "urn:schemas:mailheader:date >= '" & CDate(strInput) & "' AND urn:schemas:mailheader:date < '" & CDate(strInput) + 1 & "' AND "
strF = strF & "NOT (urn:schemas:mailheader:content-class LIKE 'IPM.Appointment%') AND NOT (urn:schemas:mailheader:content-class LIKE 'IPM.Contact%') AND "
strF = strF & "NOT (urn:schemas:mailheader:content-class LIKE 'IPM.DistList%') AND NOT (urn:schemas:mailheader:content-class LIKE 'IPM.Activity%') AND "
strF = strF & "NOT (urn:schemas:mailheader:content-class LIKE 'IPM.StickyNote%') AND NOT (urn:schemas:mailheader:content-class = 'IPM.Task') AND "
strF = strF & "NOT (urn:schemas:mailheader:content-class LIKE 'IPM.Task.%')" ' AND "
'strF = strF & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0E090102" & Chr(34) & " <> 'EF0000004B1E3AD5164F3F459BFE6A913D00E89042800000'" ' AND "
'strF = strF & "(" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0E090102" & Chr(34) & " <> 'EF0000004B1E3AD5164F3F459BFE6A913D00E89022800000')) AND "
The second approach could be the folder of the item as the unwanted ones are listed in column "In folder" with the folder name containing the a common part that is not in the folder name of the wanted items.
You can limit the search to the inbox.
strScope = "'" & Application.Session.GetDefaultFolder(olFolderInbox).folderPath & "'"
Advanced search is less capable than say .Restrict.
Delete items in Outlook by 'Type' or 'Message Class'
set restrictedItems = olSearchOlFolder.items.Restrict(" #SQL=""http://schemas.microsoft.com/mapi/proptag/0x001A001F"" LIKE 'IPM.Schedule.Meeting.%' ")
how to apply filter only on outlook messages using vba
oFilter2 = "[MessageClass] = 'IPM.Note'"
This is a theoretical implementation of "urn:schemas:mailheader:content-class", that may be applicable, from https://learn.microsoft.com/en-us/previous-versions/office/developer/exchange-server-2007/aa579702(v=exchg.80)
Private Sub AdvSearch_URN_Test()
Dim strSearch As String
Dim strDASLFilter As String
Dim strScope As String
Dim objSearch As Search
Dim strDASLFilter_option As String
Dim fldrNm As String
strScope = "'" & Session.GetDefaultFolder(olFolderInbox).Parent.folderPath & "'"
Debug.Print strScope
' https://learn.microsoft.com/en-us/previous-versions/office/developer/exchange-server-2007/aa579702(v=exchg.80)
' **** most options do nothing ****
' displayto & fromemail are functional
' search by displayto
strSearch = "to display name"
strDASLFilter_option = "displayto"
' These fail
'strDASLFilter_option = "sender" 'search by Sender
'strDASLFilter_option = "sendername" 'search by senderName
'strDASLFilter_option = "senderemail" 'search by SenderEmail
' search by content-class
' *** This fails ***
strSearch = "IPM.Note"
strDASLFilter_option = "content-class"
strDASLFilter = "urn:schemas:httpmail:" & strDASLFilter_option & " LIKE '%" & strSearch & "%'"
Debug.Print strDASLFilter
Set objSearch = AdvancedSearch(Scope:=strScope, filter:=strDASLFilter, SearchSubFolders:=True, Tag:="SearchFolder")
'Save the search results to a searchfolder
fldrNm = strDASLFilter_option & " " & strSearch
Debug.Print fldrNm
objSearch.Save fldrNm
Debug.Print fldrNm & " saved."
End Sub
I'm struggling to figure out what I need to do in order to run this code. I've based almost the entire thing off of this question:
MS Access VBA download attachment Mkdir path not exist
In which we have similar objectives, except mine is to send all fields from a table to two new folders based off of two fields "engine" and "testtype" rather than "year" and "month" as in the question posted above^.
I'm very new to VBA programming (basically started two weeks ago), and am open to any suggestions. Basically, I set the Dim for Record 1 as a string so that the field value could be read and not have an error pop up. But, I'm still using the code from the question above at the end of the script, and I'm not sure if I should keep it in, given my objective. The question above has multiple attachments in one field, whereas I just have multiple fields with strings in their records.
I'm getting the error message at the "While Not Record1.EOF" line.
Please advise if possible!
Sub Eng_Test()
Dim database As DAO.database
Dim table As DAO.Recordset
Dim PONum As String
Dim folder As String
Dim Record1 As String
Set database = CurrentDb
Dim PKey As String
Dim P2Key As String
Set table = database.OpenRecordset("tblFieldLogNOAUTO#")
folder = "C:\users"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\ndemos"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\ONEDRIVE"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
folder = folder & "\Documents"
If Len(Dir(folder, vbDirectory)) = 0 Then
MkDir folder
End If
With table
Do Until .EOF
Record1 = table.Fields("TimeDateTeam").Value
'Record2 = table.Fields("frmDate").Value
'Record3 = table.Fields("Location").Value
'Record4 = table.Fields("Engine").Value
'Record5 = table.Fields("TestType").Value
'Record6 = table.Fields("Data Locator").Value
'Record7 = table.Fields("Calibration File").Value
'Record8 = table.Fields("Engine Serial").Value
'Record9 = table.Fields("VIN Number").Value
'Record10 = table.Fields("Moe Number").Value
'Record11 = table.Fields("Name/Team").Value
'Records = Record1 & Record2 & Record3 & Record4 & Record5 & Record6 & Record7 & Record8 & Record9 & Record10 & Record11
PKey = table.Fields("Engine").Value
If Len(Dir(folder & "\" & PKey, vbDirectory)) = 0 Then
MkDir folder & "\" & PKey
End If
P2Key = table.Fields("TestType").Value
If Len(Dir(folder & "\" & PKey & "\" & P2Key, vbDirectory)) = 0 Then
MkDir folder & "\" & PKey & "\" & P2Key
End If
Eng_TestFolder = folder & "\" & PKey & "\" & P2Key
While Not Record1.EOF
Record1.Fields("FileData").SaveToFile (Eng_TestFolder)
Record1.MoveNext
Wend
.MoveNext
Loop
End With
End Sub
I've had the hardest time figuring out the below code
I am trying to save many files over the course of a day into one directory with the same name, except with a number that marks it in a successive fashion.
I have searched stackoverflow, but cannot seem to understand where I put the Save As line, within the loop to increment by one? Well, that didn't work and neither did many other tries.
Please kindly advise on this :)
Sub AutoSave()
Dim filename As String, filepath As String, filecount As Integer, filedate
As String
filedate = Format(Now(), "MM-DD-YYYY")
filepath = "C:\Users\nabil\OneDrive\Documents"
filecount = filecount + 1
Set book = Workbooks.Open("Nabil 06-06-2019 #1 Lincoln.xlsx")
' code to copy and paste here
If Len(Dir(filepath & filename)) <> 0 Then
filecount = filecount + 1
filename = "Nabil " & filedate & " " & "#" & filecount & " " & "Lincoln"
ActiveWorkbook.SaveAs filename:= _ "C:\Users\nabil\OneDrive\Documents\Nabil
" & filedate & " " & "#" & filecount & " " & "Lincoln" & ".xlsx"
End If
End Sub
Thanks for the help Mathieu. I have now edited it like this above
But now it does not want to Save As , when I put the save as in the loop or if-then statement. If I put it after the loop , then it prompts me to save over the existing file name, not saving as the file name with an increment of 1 (.e.g, #2)
This is a sliver of the code I'm using which requires that I operate from the macro workbook and open a blank template and paste data onto it , and then save as throughout the day
Please kindly advise :)
I have a small problem.
I have two for each routines. One gives me all foldernames in the current folder. The other gives me all window names opened. Both are saving the results in a String. One with newlines, the other with ~, so I can loop through both and get all the items one by one.
This is the part:
Dim Folders As String
For Each Dir As String In System.IO.Directory.GetDirectories(My.Computer.FileSystem.CurrentDirectory & "\Data\")
Dim dirInfo As New System.IO.DirectoryInfo(Dir)
Folders = Folders & dirInfo.Name & "~"
Next
Dim FolderList() As String = Folders.Split("~")
Dim p As Process
Dim Windows As String
For Each p In Process.GetProcesses
Windows = Windows & vbNewLine & p.MainWindowTitle.ToString
Next
Windows = LineTrim(Windows)
This works. But now, I want to compare them.
I only want to get the Folders, where a window exists, which contains the foldername.
For example, I have 3 folders: Test1,Test2,Test3.
I have one Window opened: "Test1 - Window"
Now I only want to get "Test1" as Result once.
I got it working so far, but I get "Test1" 3 times, because there are 3 folders. Because I am creating new Windows by this info, my function spams new windows..
This is the whole function:
Dim Folders As String
For Each Dir As String In System.IO.Directory.GetDirectories(My.Computer.FileSystem.CurrentDirectory & "\Data\")
Dim dirInfo As New System.IO.DirectoryInfo(Dir)
Folders = Folders & dirInfo.Name & "~"
Next
Dim str As String() = Folders.Split("~")
For Each Folder As String In str
If (My.Computer.FileSystem.FileExists(My.Computer.FileSystem.CurrentDirectory & "\Data\" & Folder & "\" & "Status.txt")) Then
Dim StartTime As String = Inireader.WertLesen("Settings", "StartTime", My.Computer.FileSystem.CurrentDirectory & "\Data\" & Folder & "\Time.ini")
Dim StopTime As String = Inireader.WertLesen("Settings", "StopTime", My.Computer.FileSystem.CurrentDirectory & "\Data\" & Folder & "\Time.ini")
If (IsInTime(StartTime, StopTime) = True) Then
Dim p As Process
Dim Windows As String
For Each p In Process.GetProcesses
Windows = Windows & vbNewLine & p.MainWindowTitle.ToString
Next
Windows = LineTrim(Windows)
Dim Ar() As String = Split(Windows, Environment.NewLine)
For Each Window As String In Ar
If sX.ToString.Contains(Window & " - python " & My.Computer.FileSystem.CurrentDirectory & "\Data\" & Window& "\" & Window & ".py") Then ''''The Spam cause line
Else
Dim Path = My.Computer.FileSystem.CurrentDirectory & "\Data\" & Folder & "\" & Folder & ".py"
Dim startInfo As New ProcessStartInfo
startInfo.FileName = "cmd.exe"
startInfo.Arguments = "/k " & "title " & Folder & " & python " & Path
startInfo.WorkingDirectory = My.Computer.FileSystem.CurrentDirectory & "\Data\" & Folder & "\"
Process.Start(startInfo)
End If
Next
End If
End If
Next
I can´t shorten it very much..
Could you help me out?
Thank you :)
Best regards!
I am using MS Access Forms and I am trying to open a file but don't know how to open the file based knowing only part of the name. Example below works
Private Sub Open_Email_Click()
On Error GoTo Err_cmdExplore_Click
Dim x As Long
Dim strFileName As String
strFileName = "C:\data\office\policy num\20180926 S Sales 112.32.msg"
strApp = """C:\Program Files\Microsoft Office\Office15\Outlook.exe"""
If InStr(strFileName, " ") > 0 Then strFileName = """" & strFileName & """"
x = Shell(strApp & " /f " & strFileName)
Exit_cmdExplore_Click:
Exit Sub
Err_cmdExplore_Click:
MsgBox Err.Description
Resume Exit_cmdExplore_Click
End Sub
If I change the strFilename to being
strFileName = "C:\data\" & Me.Office & "\" & Me.nm & " " & Me.pol & "\" & "*"& " S Sales " & Me.amt & "*" & ".msg"
It includes the * rather than using it as a wildcard, the date/numbers can be anything or in another format but always eight numbers. I tried using a while loop on the numbers but I am not sure the best way of doing this sorry.
You can use the Dir function to iterate over all files that match a string pattern.
strApp = """C:\Program Files\Microsoft Office\Office15\Outlook.exe"""
Dim strFilePattern As String
strFilePattern ="C:\data\" & Me.Office & "\" & Me.nm & " " & Me.pol & "\" & "*"& " S Sales " & Me.amt & "*" & ".msg"
Dim strFileName As String
strFileName = Dir(strFilePattern)
Do While Not strFileName = vbNullString
If InStr(strFileName, " ") > 0 Then strFileName = """" & strFileName & """"
x = Shell(strApp & " /f " & strFileName)
strFileName = Dir
Loop
The first call to Dir with the pattern as a parameter will find the first file that matches the pattern supplied. All subsequent calls without the pattern will return the next file that matches the pattern.
So, lets rebuild the question a bit. Imagine that you are having the following 5 files in a given folder:
A:\peter.msg
A:\bstack.msg
A:\coverflow.msg
A:\heter.msg
A:\beter.msg
and you need to find the files, that correspond to "A:\*eter.msg" and print them.
For this, you need to use the keyword Like:
Sub TestMe()
Dim someNames As Variant
someNames = Array("A:\peter.msg", "A:\bstack.msg", _
"A:\coverflow.msg", "A:\heter.msg", "A:\beter.msg")
Dim cnt As Long
For cnt = LBound(someNames) To UBound(someNames)
If someNames(cnt) Like "A:\*eter.msg" Then
Debug.Print someNames(cnt)
End If
Next
End Sub
Loop through files in a folder using VBA?