How to Create, Open, attach and use Temporary Email Files with Outlook

[binduau]

How to Create, Open, attach and use Temporary Email Files with Outlook 2000

sFileName = Replace(sFileName, Chr(32), "_", 1)

'Collect the Data

'If any temporary files exist or if the function or program 
'crashes, the temporary files are deleted at startup also.
 
'Initialize the send parameters
 
Private Sub mnuOsend_Click()
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

Get the filename

Function Locate_OpenFile(dlgtitle As String, strFilter As String, InitDir _
As String) As String
On Error GoTo err_Open
 'set the string value of the email reply template folder
         Dim sBuf As String
        
        Cmdialog.Filter = strFilter
        Cmdialog.InitDir = InitDir
        Cmdialog.DialogTitle = dlgtitle
        Cmdialog.ShowOpen
             
       If Len(Cmdialog.FileName) <> 0 Then
                'send the filename back
            Locate_OpenFile = Cmdialog.FileName
  
        End If
Exit_Open:
Exit Function
err_Open:
MsgBox Err.Description
Resume Exit_Open
 
 
End Function

'Open a New message with the attached file

Public Sub Open_Out_Folder(FolderToOpen As String, intview As Integer)
 On Error GoTo err_Open_Out
 Dim strFileName As String, wShell As Object, StrAppName As String
    Screen.MousePointer = vbHourglass
 
'get the path to outlook from the registry
 
StrAppName = GetRegStringValue$(HKEY_LOCAL_MACHINE, _
"Software\Microsoft\Windows\CurrentVersion\App Paths\outlook.exe", "")
 
Select Case intview
Case 0
    'The folder name can't have a space in it
    'Open The Folder
     strFileName = StrAppName & " /select outlook:" & FolderToOpen
    
Case 1
'StickyNote Appointment Task
     strFileName = StrAppName & " " & FolderToOpen
 
Case 2
'Send an attached file
 
End Select
 
    Shell strFileName, vbNormalFocus
     Screen.MousePointer = vbDefault
exit_Open_Out:
Exit Sub
err_Open_Out:
MsgBox Err.Description
Resume exit_Open_Out
End Sub

'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

'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