How to Open a new message in Outlook with a file attached

[binduau]

You are free to use all this code any way you want.

If you have any questions post a reply to this thread
i have included the llistbox functions as well so you can
choose a file from a list and send it.. YOu will have to adapt
it a little for your own purposes.........

'Collect the Data
'NOTES:
'You will need references to the outlook 9 or 10 object library

'1. Create a form and name it FrmEmailConfig

2. Add a command button called CmdSendAttached

3. 'Add a common dialog named Cmdialog
if the common dialog is unavailabel in the toolbox right click on
the toolbox and Click on components ...make sure that the
Selected Items Only Checkbox is "Cleared"
Scroll down and find microsoft common dialog control and
select it by setting the check to selected. Clcik on Apply Then
OK..
'4. Add a listbox named LstFilesSaved

' 5. Add the FxShared bas module to your project (it is in the zip file)

'6 paste the code below into the general section of your form.


'Note
FxShared bas is a bas file i found somewhereor other and have added to over the months... 80% of it is my own work

Private Sub CmdSendAttached_Click()
'If any temporary files exist or if the function or program 
'crashes, the temporary files are deleted at startup also.
'Initialize the send parameters
 
On Error GoTo err_Attach
Dim _
strFname As String, _
strTemp As String, _
i As Integer, _
strFilter As String
 
'i want to kill outlook
TerminateEXE "OUTLOOK.EXE"
 
'get the file from the cmdialog
'i was going to use an API cmdialog but
'i can't be bothered DOH!
 strFilter = "Archived Order Files (*.txt)|*.txt|" _
            & "HTML Template Files (*.html)|*.html|" _
            & "All Files (*.*)|*.*|" _
            & "HTM Template Files(*.htm)|*.htm|" _
            & "Template Files(*.tpl)|*.tpl|" _
            & "Log Files(*.Log)|*.Log"
'Open the dialog
strFname = Locate_OpenFile("Please Select a a File To Attach to This Mail.", strFilter, DefOutPutFolder)
 
'in my temporary files i put an underscore because outlook
'hates spaces in its attach command line switch
 
If Len(strFname) <> 0 Then
    'Replace the spaces in the filename with the
    'underscore character
    For i = 1 To Len(strFname)
        If Mid(strFname, i, 1) <> Chr(32) Then
            strTemp = strTemp & Mid(strFname, i, 1)
        Else
            strTemp = strTemp & "_"
        End If
    Next i
    
    'Check if the file exists
        If Len(Dir(strTemp)) = 0 Then
            'Create a temporary file
            FileCopy strFname, strTemp
        Else
            'if the temporary file pre-exists delete it.
            Kill strTemp
            'Create a NEW temporary file
            FileCopy strFname, strTemp
        End If
        
    'Open a new email  message with the file attached
    Open_Out_Folder "/a " & strTemp, 1
  
End If
Exit_Attach:
Exit Sub
err_Attach:
MsgBox Err.Description
Resume Exit_Attach
End Sub

'Add this to your forms general section
'and Call this at Startup to do what you want

Sub loadFileList()
On Error GoTo ErrorHandler
'Image1.Picture = Image2.Picture
Dim SearchPath As String, FindStr As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Screen.MousePointer = vbHourglass
SearchPath = DefOutPutFolder
FindStr = "*.txt"
 
'Locate all the files for the list.
FileSize = FindFiles(SearchPath, FindStr, NumFiles, NumDirs)
Exit_LoadFile:
Screen.MousePointer = vbDefault
Exit Sub
 
ErrorHandler:
MsgBox Err.Description
Resume Exit_LoadFile
End Sub

This is the FindFiles function called from the sub above
'what it does is sort thru the folder in the passed varialbes
'adding filenames found to a list box.

'P.S i don't feel like indenting this at the correct places

Public Function FindFiles(path As String, SearchStr As String, _
FileCount As Integer, DirCount As Integer)
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
nDir = 0
LstFilesSaved.Clear
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden)
Do While Len(DirName) > 0
 
If (DirName <> ".") And (DirName <> "..") Then
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
sysFileERRCont:
End If
DirName = Dir()
Loop
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly)
While Len(FileName) <> 0
FileCount = FileCount + 1
 
'in my temporary files i put an underscore because outlook
'hates spaces in its attach command line switch
If InStr(FileName, "_") = 0 Then
  
FindFiles = FindFiles + FileLen(path & FileName)
LstFilesSaved.AddItem FileName
Else
  Kill path & FileName
    
End If
FileName = Dir()
 
Wend
If nDir > 0 Then
For i = 0 To nDir - 1
FindFiles = FindFiles + FindFiles(path & dirNames(i) & "\", _
SearchStr, FileCount, DirCount)
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
"Unexpected Error"
'Resume Next
Resume AbortFunction
End If
End Function

bindu