Solved: FileSearch in Outlook

[mdmackillop]

Before I save an attachment, I want to check if a previous version exists, and if so add an increment to the name. This is failing at the FileSearch line. Any ideas?

Function DocSave(strFolderPath As String, DocName As String) As String

Dim Ext As String, SaveName As String

Ext = Right(DocName, 4)
SaveName = Left(DocName, Len(DocName) - 4)

With Application.FileSearch
.NewSearch
.LookIn = strFolderPath
.SearchSubFolders = False
.FileName = DocName
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
DocSave = strFolderPath & SaveName & "-" & .FoundFiles.Count & Ext
Else
DocSave = strFolderPath & DocName
End If
End With
End Function

[mdmackillop]

I found this on the MS site (http://msdn2.microsoft.com/en-us/library/aa141271(office.10).aspx), but which reference do they mean?




Every Microsoft? Office application includes accessor properties that provide access to the shared Office components. For example, an Office application's Assistant property returns a reference to the Assistant object, the FileSearch property returns a reference to the FileSearch object, and the Scripts property returns a reference to the Scripts collection. From within any Office application, you can return a reference to a shared component object by using the appropriate accessor property; you do not have to use the New keyword to create an object variable that references the shared Office component.
Note All Office applications, except Microsoft? Access, Microsoft? FrontPage?, and Microsoft? Outlook?, include a reference to the Microsoft Office XP object library by default. Before you can work with shared Office components in Access, FrontPage, or Outlook, you must first manually set a reference to the Microsoft Office XP object library.

[mdmackillop]

I've used a workaround setting a reference to Word, but I'd rather do this "properly."
Here's the almost finished code.
Option Explicit
Dim wdApp As Word.Application
Dim fs

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim Att As Outlook.Attachment
Dim strfile As String
Dim strfolderpath As String
Dim FirstCount As Long

' Get the path to your My Documents folder
strfolderpath = JobFolder(InputBox("Job No."))
If MsgBox("This will copy attachments to" & vbCr & strfolderpath & vbCr & vbCr _
& "Do you wish to continue?", 36) = vbNo Then Exit Sub

'Create full path; ckeck if it exists
strfolderpath = "M:\" & strfolderpath & "\Attachments\"
If Not MyFolderExists(strfolderpath) Then MkDir strfolderpath

'Check attachment count before copying
Set wdApp = New Word.Application
Set fs = wdApp.FileSearch
FirstCount = Copied(strfolderpath)

'Get the email
Set objOL = CreateObject("Outlook.Application")
Set objMsg = objOL.ActiveExplorer.Selection.Item(1)

'Save the attachments with incremental names
For Each Att In objMsg.Attachments
strfile = Att.FileName
Att.SaveAsFile DocSave(strfolderpath, strfile)
Next

'Check attachment count after copying
MsgBox Copied(strfolderpath) - FirstCount & " attachment(s) copied to " & strfolderpath

If MsgBox("Delete email?", 36) = vbYes Then objMsg.Delete

ExitSub:
wdApp.Quit
Set wdApp = Nothing
Set objMsg = Nothing
Set objOL = Nothing
End Sub

'Get the full folder name from the Database
Function JobFolder(ToFind As Long)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim Sql As String

Sql = "SELECT [Contract Details].[Job No], [Contract Details].Project " & _
"FROM [Contract Details] WHERE ((([Contract Details].[Job No])=" & ToFind & "));"

Set dbs = OpenDatabase("S:\Database\ContractData.mdb")
Set rst = dbs.OpenRecordset(Sql)

JobFolder = Format(rst("Job No"), "0000") & " " & rst("Project")

CleanUp:
Set rst = Nothing
Set dbs = Nothing
End Function

'Check if the folder exists
Public Function MyFolderExists(Path As String) As Boolean
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Select Case objFSO.FolderExists(Path)
Case True
MyFolderExists = True
Case False
MyFolderExists = False
End Select
Set objFSO = Nothing
End Function

'Check if the attachment name exists, if so, add an increment
Function DocSave(strfolderpath As String, DocName As String) As String
Dim Ext As String, SaveName As String
'Get extension and filename
Ext = Right(DocName, 4)
SaveName = Left(DocName, Len(DocName) - 4)
With fs
.NewSearch
.LookIn = strfolderpath
.SearchSubFolders = False
.FileName = DocName
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
'Apply increment
DocSave = strfolderpath & SaveName & "-" & .FoundFiles.Count & Ext
Else
DocSave = strfolderpath & DocName
End If
End With
End Function

'Count the files in the attachment folder
Function Copied(strfolderpath As String) As Long
With fs
.NewSearch
.FileType = msoFileTypeAllFiles
.LookIn = strfolderpath
.Execute
Copied = .FoundFiles.Count
End With
End Function

[Norie]

Why not use the File System Object?

If you used late binding you wouldn't need any references.

PS I just spotted your already using it to see if the folder exists.:oops: