So i have a form that creates a chart based on a different file.
I'm trying to write code that does this:
User clicks "Get Data"
Form opens
User clicks the directory from which to get files
Code opens directory and populates a combobox in form with file names beginning with gmn
User clicks the files they want to get data from
macro is called and all data is added
I'm not any good with vba or excel but hey I'm learning. So the problem is that I have idea what to use to get the files? I tried looking at other post but they are just getting specific files. Any help is greatly appreciated! And if more info is needed let me know!
Code and Pics:
Private Sub ComboBoxDir_Change()
'populate our directories
Dim DirNow As String
DirNow = Dir("\\na.luk.com\wooster\DATA\NL-LUS-E\EAD\Tom_Freshly\SAE2\TestsDone\GMN10055\Ford-A oil\Inspection\" + Me.ComboBoxDir + "\*", vbNormal)
'loop to fill up pull down
Do While DirNow <> ""
'add items to combo
UserFormDataa.ComboBoxFiles.AddItem (DirNow)
'get next dir
DirNow = Dir()
Loop
'Now add files
Call GetFilesFromDirect("")
End Sub
Private Sub GetFilesFromDirect(DirectNow As String)
Dim file As Variant
file = Dir("DirectNow")
While (file <> "")
If InStr(file, "Gmn*") > 0 Then
ComboBoxFiles.AddItem (file)
End If
file = Dir
Wend
End Sub
Private Sub ComboBoxFiles_Change()
End Sub
Private Sub GetSheets_Click()
Call GetData
End Sub
This should populate with all the elements that begin with "gmn" within DirNow Address
...
Do While DirNow <> ""
Dim oFSO as Object
Dim FileItem as Variant
Dim oFolder as Object
Set oFSO = CreateObject("Scripting.FileSystemObject") 'library needed to do stuff related to file management
Set oFolder = oFSO.GetFolder(DirNow)
UserFormDataa.ComboBoxFiles.Clear 'no previous data needed (if any)
For each FileItem in oFolder.Files
'add items to combo
If Instr(FileItem.Name,"gmn") >0 Then UserFormDataa.ComboBoxFiles.AddItem (FileItem.Name)
'I'd ignore case "GMN" won't be added) If Instr(lCase(FileItem.Name)...
Next FileItem
Loop
...
OT: While I'm partially agree that File Dialog may be a better approach, I guess this kind of works too to make it easier to the users. I don't understand why comments suggested GetSaveAsFileName since you state there may be multiple user selections I'd go for GetOpenFilename or, it could be better to go with GetFolder
Related
I've tried to use the below code which I found on this conversation How To Search And Replace Across Multiple Files In Word? supplied by Charles Kenyon. However, it doesn't seem to work for me. I've enabled macros on my word and added the below code as a new module in Macros. When I go to replace all, it'll replace the text as per normal, but after doing this, when I open up the other macros enabled word doc, I find that the same text is still in these docs, without being replaced. Am I doing something wrong? Namely, I also wish to add a wildcard entry into my replace all, will the below code work or can someone suggest a better alternative? I have tested the below code with and without wildcard entries to no avail. I've also tried the code on this page in my macros but it also didn't work How to find and replace a text in multiple Word documents using VBAThanks for any help!
Option Explicit
Public Sub BatchReplaceAll()
Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
PathToUse = "C:\Test\"
'Error handler to handle error generated whenever
'the FindReplace dialog is closed
On Error Resume Next
'Close all open documents before beginning
Documents.Close SaveChanges:=wdPromptToSaveChanges
'Boolean expression to test whether first loop
'This is used so that the FindReplace dialog will
'only be displayed for the first document
FirstLoop = True
'Set the directory and type of file to batch process
myFile = Dir$(PathToUse & "*.doc")
While myFile <> ""
'Open document
Set myDoc = Documents.Open(PathToUse & myFile)
If FirstLoop Then
'Display dialog on first loop only
Dialogs(wdDialogEditReplace).Show
FirstLoop = False
Response = MsgBox("Do you want to process " & _
"the rest of the files in this folder", vbYesNo)
If Response = vbNo Then Exit Sub
Else
'On subsequent loops (files), a ReplaceAll is
'executed with the original settings and without
'displaying the dialog box again
With Dialogs(wdDialogEditReplace)
.ReplaceAll = 1
.Execute
End With
End If
'Close the modified document after saving changes
myDoc.Close SaveChanges:=wdSaveChanges
'Next file in folder
myFile = Dir$()
Wend
End Sub
I'm using Visual Studio to build an addin to copy emails.
The condition is to check, according to SentOn/ReceivedTime, and copy only those emails from the source folder that do not exist in the destination folder.
I tried below code but its gives me an error System.OutOfMemoryException Out of memory or system resources.
Sub CopyMail(SourceFolder As Outlook.Folder, DestinationFolder As Outlook.Folder)
Dim sMail As Object
Dim dMail As Object
Dim MailC As Object
For Each sMail In SourceFolder.Items
For Each dMail In DestinationFolder.Items
If sMail.SentOn <> dMail.SentOn Then
MailC = sMail.Copy
MailC.Move(DestinationFolder)
End If
Next
Next
End Sub
There is a logic error in your nested loop - for each item in the destination folder you copy all non-matches from the source folder, even though those items may match other items in the destination folder.
Here's an approach (untested) which should work.
It's in VBA: my VB.NET is not good and anyway you tagged with VBA...
Sub CopyMail(SourceFolder As Outlook.Folder, DestinationFolder As Outlook.Folder)
Dim sMail As Object
Dim dMail As Object
Dim MailC As Object
Dim dictSent As New Scripting.dictionary, i As Long
'get a list of all unique sent times in the
' destination folder
For Each dMail In DestinationFolder.Items
dictSent(dMail.SentOn) = True
Next
'loop through the source folder and copy all items where
' the sent time is not in the list
For i = SourceFolder.Items.Count To 1 Step -1
Set sMail = SourceFolder.Items(i)
If Not dictSent.Exists(sMail.SentOn) Then
Set MailC = sMail.Copy 'copy and move
MailC.Move DestinationFolder
dictSent(sMail.SentOn) = True 'add to list
End If
Next i
End Sub
First Time Question :D.
I have been writing a Marco for Outlook 2007 to let the user pick a folder and then with that folder move all the mail items out of it and move it to a personal Arhcive folder where using the selected folder name as the destination under a personal folder.
e.g.
User selects a randon folder with ther name 'Test'
The marco would be pre mapped to personal folder and then it would locate the sub folder with the same name and move the mail items.
My questions:
I Currently am using the '.PickFolder' Syntax to have the use select the folder, What i what to do is have a Multi Select folders form:
How would i go about getting the Mapi of all the fodlers to appear in a custom Form using the Combobox and listbox forms.
I understand this would only be at one level but that is all i require as the 200+ folders are at one level.
As the code is, It works brilliantly with one folder at a time but i wish to up the anti .
Thnak you.
I've tackled the problem of getting a full list of folders (code below) but if you need more help with other parts please add a comment and I will expand upon my answer.
I didn't understand what you would do with a ComboBox. So for this example I have created a form and added a ListBox (called ListBox1). The code below will populate the listbox with the names of all the folders from a selected folder downwards. Please read the comments to see what else you can do (e.g. recurse through subfolders - I know that's not required in this case).
Please do let me know if you need more help or information.
Private Sub PopulateListBoxWithFolders()
Dim objApp As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
' Clear current contents of listbox
ListBox1.Clear
Set objApp = New Outlook.Application
Set objNamespace = objApp.GetNamespace("MAPI")
' Allow user to select folder.
' Replace this with either objNamespace.GetDefaultFolder(...) or objNamespace.GetFolderFromID(...)
' to avoid the user having to select a folder
Set objFolder = objNamespace.PickFolder
' See if the user cancelled or no folder found
If Not objFolder Is Nothing Then
' Addition of true here recurses through all subfolders
ProcessFolder objFolder ', True
End If
End Sub
' Populates the ListBox with the folders. Optionally you can recurse all folders
Sub ProcessFolder(objStartFolder As Outlook.MAPIFolder, Optional blnRecurseSubFolders As Boolean = False, Optional strFolderPath As String = "")
Dim objFolder As Outlook.MAPIFolder
Dim i As Long
' Loop through the items in the current folder
For i = 1 To objStartFolder.Folders.Count
Set objFolder = objStartFolder.Folders(i)
' Populate the listbox
ListBox1.AddItem ListBox1.Text + objFolder.FolderPath
If blnRecurseSubFolders Then
' Recurse through subfolders
ProcessFolder objFolder, True, strFolderPath + "\" + objFolder.FolderPath
End If
Next
End Sub
If you need code to identify the selected items in a multiselect ListBox here it is. To make the ListBox multiselect you should set the MultiSelect property in the form editor to 1 - fmMultiSelectMulti
Private Sub btnOK_Click()
Dim i As Long
' Loop through all items in the listbox identifying those that are selected
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
' Here goes the code to act on the selected item
' In the example below it outputs to the Immediate window
Debug.Print .List(i)
End If
Next i
End With
End Sub
I need to build a tool that will allow the user to select an email from his Outlook so I can then save that email as a .msg file or alternately save just the attachment as a file.
I'm stumbling a little bit over what might be the easiest and the best way to allow searching/filtering of emails. I need to give the user a view that is at least slightly similar to Outlook (for example, folders should be the same order/hierarchy.
Does the Outlook Object Model have some kind of Explorer/Picker/Selection dialog I can call that will return a storeid and an entryid after the user selects an email? Or do I need to roll my own?
I should mention that I already know how to save the email or attachment so my question is only about handling selection and filtering of emails.
FYI, I'm programming this in MS Access 2007 with Outlook 2007. The target machines have either 2007 or 2010 versions of Access and Outlook.
Linking to the Outlook table is fine. The problem is that Outlook doesn't provide a unique ID to each message and if the message is moved from one folder to another, its ID changes. Clearly not designed by someone who understands databases.
A better approach may be to create an Outlook add-in that runs within Outlook, then performs the tasks you need to send the info to Access.
I rarely program with Access but I moved some code across from Outlook, hacked it around a bit and it seems to work. This is not a solution but it should show you how to access all the information you need.
I had one problem. Neither Set OutApp = CreateObject("Outlook.Application") nor Set OutApp = New Outlook.Application create a new instance of Outlook if one is already open. So Quit closes Outlook whether or not it was open before the macro started. I suggest you post a new question on this issue; I am sure someone knows how to tell if Outlook is already open and therefore not to quit it.
The folder structure in Outlook is slightly awkward because the top level folders are of type Folders while all sub-folders are of type MAPIFolder. Once you have got past that it is fairly straightforward.
The code below includes function GetListSortedChildren(ByRef Parent As MAPIFolder) As String. This function finds all the children of Parent and returns a string such as "5,2,7,1,3,6,4" which lists the indices for the children in ascending sequence by name. I would use something like this to populates a ListView by expanding nodes as the user required.
I have provided a subroutine CtrlDsplChld() which controls the output to the immediate windows of all the folders in sequence. I believe that should give you enough guidance to get started on accessing the folder hierarchy.
Subroutine DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long) includes code to find the first message with attachments. This will you tell you how to look through a folder for a particular message.
Finally, CtrlDsplChld() displayes selected properties of the message: Subject, To, HTMLBody and the display names of the attachments.
Hope this helps.
Option Compare Database
Option Explicit
Dim ItemWithMultipleAttachments As Outlook.MailItem
Sub CtrlDsplChld()
Dim ArrChld() As String
Dim ListChld As String
Dim InxAttach As Long
Dim InxChld As Long
Dim InxTopLLCrnt As Long
Dim OutApp As Outlook.Application
Dim TopLvlList As Folders
Set ItemWithMultipleAttachments = Nothing
Set OutApp = CreateObject("Outlook.Application")
'Set OutApp = New Outlook.Application
With OutApp
Set TopLvlList = .GetNamespace("MAPI").Folders
For InxTopLLCrnt = 1 To TopLvlList.Count
' Display top level children and their children
Call DsplChld(TopLvlList.Item(InxTopLLCrnt), 0)
Next
If Not ItemWithMultipleAttachments Is Nothing Then
With ItemWithMultipleAttachments
Debug.Print .Subject
Debug.Print .HTMLBody
Debug.Print .To
For InxAttach = 1 To .Attachments.Count
Debug.Print .Attachments(InxAttach).DisplayName
Next
End With
End If
.Quit
End With
Set OutApp = Nothing
End Sub
Sub DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long)
Dim ArrChld() As String
Dim InxChld As Long
Dim InxItemCrnt As Long
Dim ListChld As String
Debug.Print Space(Level * 2) & Parent.Name
If ItemWithMultipleAttachments Is Nothing Then
' Look down this folder for a mail item with an attachment
For InxItemCrnt = 1 To Parent.Items.Count
With Parent.Items(InxItemCrnt)
If .Class = olMail Then
If .Attachments.Count > 1 Then
Set ItemWithMultipleAttachments = Parent.Items(InxItemCrnt)
Exit For
End If
End If
End With
Next
End If
ListChld = GetListSortedChildren(Parent)
If ListChld <> "" Then
' Parent has children
ArrChld = Split(ListChld, ",")
For InxChld = LBound(ArrChld) To UBound(ArrChld)
Call DsplChld(Parent.Folders(ArrChld(InxChld)), Level + 1)
Next
End If
End Sub
Function GetListSortedChildren(ByRef Parent As MAPIFolder) As String
' The function returns "" if Parent has no children.
' If the folder has children, the functions returns "P,Q,R, ..." where
' P, Q, R and so on indices of the children of Parent in ascending
' order by name.
Dim ArrInxFolder() As Long
'Dim ArrFolder() As MAPIFolder
Dim InxChldCrnt As Long
Dim InxName As Long
Dim ListChld As String
If Parent.Folders.Count = 0 Then
' No children
GetListSortedChildren = ""
Else
'ReDim ArrName(1 To Parent.Folders.Count)
'For InxChldCrnt = 1 To Parent.Folders.Count
' ArrFolder(InxChldCrnt) = Parent.Folders(InxChldCrnt)
'Next
Call SimpleSortMAPIFolders(Parent, ArrInxFolder)
ListChld = CStr(ArrInxFolder(1))
For InxChldCrnt = 2 To Parent.Folders.Count
ListChld = ListChld & "," & CStr(ArrInxFolder(InxChldCrnt))
Next
GetListSortedChildren = ListChld
End If
End Function
Sub SimpleSortMAPIFolders(ArrFolder As MAPIFolder, _
ByRef InxArray() As Long)
' On exit InxArray contains the indices into ArrFolder sequenced by
' ascending name. The sort is performed by repeated passes of the list
' of indices that swap adjacent entries if the higher come first.
' Not an efficient sort but adequate for short lists.
Dim InxIACrnt As Long
Dim InxIALast As Long
Dim NoSwap As Boolean
Dim TempInt As Long
ReDim InxArray(1 To ArrFolder.Folders.Count) ' One entry per sub folder
' Fill array with indices
For InxIACrnt = 1 To UBound(InxArray)
InxArray(InxIACrnt) = InxIACrnt
Next
If ArrFolder.Folders.Count = 1 Then
' One entry list already sorted
Exit Sub
End If
' Each repeat of the loop moves the folder with the highest name
' to the end of the list. Each repeat checks one less entry.
' Each repeats partially sorts the leading entries and may result
' in the list being sorted before all loops have been performed.
For InxIALast = UBound(InxArray) To 1 Step -1
NoSwap = True
For InxIACrnt = 1 To InxIALast - 1
If ArrFolder.Folders(InxArray(InxIACrnt)).Name > _
ArrFolder.Folders(InxArray(InxIACrnt + 1)).Name Then
NoSwap = False
' Move higher entry one slot towards the end
TempInt = InxArray(InxIACrnt)
InxArray(InxIACrnt) = InxArray(InxIACrnt + 1)
InxArray(InxIACrnt + 1) = TempInt
End If
Next
If NoSwap Then
Exit For
End If
Next
End Sub
Using VBA. My script moves a file into a directory. If that filename already exists in the target directory, I want the user to be prompted to rename the source file (the one that's being moved) before the move is executed.
Because I want the user to know what other files are in the directory already (so they don't choose the name of another file that's already there), my idea is to open a FileDialog box listing the contents of the directory, so that the user can use the FileDialog box's native renaming capability. Then I'll loop that FileDialog until the source file and target file names are no longer the same.
Here's some sample code:
Sub testMoveFile()
Dim fso As FileSystemObject
Dim file1 As File
Dim file2 As File
Dim dialog As FileDialog
Set fso = New FileSystemObject
fso.CreateFolder "c:\dir1"
fso.CreateFolder "c:\dir2"
fso.CreateTextFile "c:\dir1\test.txt"
fso.CreateTextFile "c:\dir2\test.txt"
Set file1 = fso.GetFile("c:\dir1\test.txt")
Set file2 = fso.GetFile("c:\dir2\test.txt")
Set dialog = Application.FileDialog(msoFileDialogOpen)
While file1.Name = file2.Name
dialog.InitialFileName = fso.GetParentFolderName(file2.Path)
If dialog.Show = 0 Then
Exit Sub
End If
Wend
file1.Move "c:\dir2\" & file1.Name
End Sub
But when I rename file2 and click 'OK', I get an error:
Run-time error '53': File not found
and then going into the debugger shows that the value of file2.name is <File not found>.
I'm not sure what's happening here--is the object reference being lost once the file's renamed? Is there an easier way to let the user rename from a dialog that shows all files in the target directory? I'd also like to provide a default new name for the file, but I can't see how I'd do that using this method.
edit: at this point I'm looking into making a UserForm with a listbox that gets populated w/ the relevant filenames, and an input box with a default value for entering the new name. Still not sure how to hold onto the object reference once the file gets renamed, though.
Here's a sample of using Application.FileDialog to return a filename that the user selected. Maybe it will help, as it demonstrates getting the value the user provided.
EDIT: Modified to be a "Save As" dialog instead of "File Open" dialog.
Sub TestFileDialog()
Dim Dlg As FileDialog
Set Dlg = Application.FileDialog(msoFileDialogSaveAs)
Dlg.InitialFileName = "D:\Temp\Testing.txt" ' Set suggested name for user
' This could be your "File2"
If Dlg.Show = -1 Then
Dim s As String
s = Dlg.SelectedItems.Item(1) ` Note that this is for single-selections!
Else
s = "No selection"
End If
MsgBox s
End Sub
Edit two: Based on comments, I cobbled together a sample that appears to do exactly what you want. You'll need to modify the variable assignments, of course, unless you're wanting to copy the same file from "D:\Temp" to "D:\Temp\Backup" over and over. :)
Sub TestFileMove()
Dim fso As FileSystemObject
Dim SourceFolder As String
Dim DestFolder As String
Dim SourceFile As String
Dim DestFile As String
Set fso = New FileSystemObject
SourceFolder = "D:\Temp\"
DestFolder = "D:\Temp\Backup\"
SourceFile = "test.txt"
Set InFile = fso.GetFile(SourceFolder & SourceFile)
DestFile = DestFolder & SourceFile
If fso.FileExists(DestFile) Then
Dim Dlg As FileDialog
Set Dlg = Application.FileDialog(msoFileDialogSaveAs)
Dlg.InitialFileName = DestFile
Do While True
If Dlg.Show = 0 Then
Exit Sub
End If
DestFile = Dlg.Item
If Not fso.FileExists(DestFile) Then
Exit Do
End If
Loop
End If
InFile.Move DestFile
End Sub
Here's some really quick code that I knocked up but basically looks at it from a different angle. You could put a combobox on a userform and get it to list the items as the user types. Not pretty, but it's a start for you to make more robust. I have hardcoded the directory c:\ here, but this could come from a text box
Private Sub ComboBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger,
ByVal Shift As Integer)
Dim varListing() As Variant
Dim strFilename As String
Dim strFilePart As String
Dim intFiles As Integer
ComboBox1.MatchEntry = fmMatchEntryNone
strFilePart = ComboBox1.Value
strFilename = Dir("C:\" & strFilePart & "*.*", vbDirectory)
Do While strFilename <> ""
intFiles = intFiles + 1
ReDim Preserve varListing(1 To intFiles)
varListing(intFiles) = strFilename
strFilename = Dir()
Loop
On Error Resume Next
ComboBox1.List() = varListing
On Error GoTo 0
ComboBox1.DropDown
End Sub
Hope this helps. On error resume next is not the best thing to do but in this example stops it erroring if the variant has no files