How to Create, Open, attach and use Temporary Email Files with Outlook 2000
VB Code:
sFileName = Replace(sFileName, Chr(32), "_", 1)
'Collect the Data
VB Code:
'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
VB Code:
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
VB Code:
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
VB Code:
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
VB Code:
'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