Option Compare Database
Option Explicit
Declare Function apiShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
'***App Window Constants***
Public Const WIN_NORMAL = 1 'Open Normal
Public Const WIN_MAX = 3 'Open Maximized
Public Const WIN_MIN = 2 'Open Minimized
'***Error Codes***
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11& 'Open Normal
Public Function vcSendThunderbird(strTo As String, strSubject As String, strBody As String, strFile As String)
'This function can be used to send an e-mail from Mozilla Thunderbird.
'
Dim strCommand As String
strFile = "file:///" & strFile & ""
If InStr(GetDefaultEmailProgramName, "hunderbird") > 0 Then
strCommand = GetDefaultEmailProgramPath & GetDefaultEmailProgramName
Else
strCommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
End If
'strCommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
strCommand = strCommand & " -compose to=" & strTo & Chr$(34) & ","
strCommand = strCommand & "subject=" & Chr$(34) & strSubject & Chr$(34) & ","
strCommand = strCommand & "body=" & Chr$(34) & strBody & Chr$(34) & ","
strCommand = strCommand & "attachment=" & Chr$(34) & strFile & Chr$(34) & ""
Call Shell(strCommand, vbNormalFocus)
End Function
Public Function vcSendThunderbirdwithBCC(strTo As String, strBCC As String, strSubject As String, strBody As String, strFile As String)
'This function can be used to send an e-mail from Mozilla Thunderbird.
'
Dim strCommand As String
strFile = "file:///" & strFile & ""
If GetDefaultEmailProgramPath = "Thunderbird" Then
strCommand = GetDefaultEmailProgramPath & GetDefaultEmailProgramPath
Else
strCommand = "C:\Program Files\Mozilla Thunderbird\thunderbird"
End If
strCommand = strCommand & " -compose to=" & strTo & Chr$(34) & ","
strCommand = strCommand & "bcc=" & strBCC & Chr$(34) & ","
strCommand = strCommand & "subject=" & Chr$(34) & strSubject & Chr$(34) & ","
strCommand = strCommand & "body=" & Chr$(34) & strBody & Chr$(34) & ","
strCommand = strCommand & "attachment=" & Chr$(34) & strFile & Chr$(34) & ""
Call Shell(strCommand, vbNormalFocus)
End Function
Function GetDefaultEmailProgramName() As String
'Written: November 30, 2008
'Author: Leith Ross
'Summary: Function returns the name of the default email program.
' This works with Excel 2000 and up.
Dim DefaultEmail As String
Dim i As Long
Dim ProgPath As Variant
Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
DefaultEmail = WSH.RegRead("HKCR\mailto\shell\open\command\")
i = InStr(2, DefaultEmail, Chr$(34))
DefaultEmail = Mid(DefaultEmail, 2, i - 2)
'This separates the email program name from the full path
ProgPath = Split(DefaultEmail, "\")
GetDefaultEmailProgramName = (ProgPath(UBound(ProgPath)))
'GetDefaultEmailProgramName = Replace(GetDefaultEmailProgramName, ".exe", "")
Set WSH = Nothing
End Function
Function GetDefaultEmailProgramPath() As String
'Written: November 30, 2008
'Author: Leith Ross
'Summary: Function returns the name of the default email program.
' This works with Excel 2000 and up.
Dim DefaultEmail As String
Dim i As Long
Dim ProgPath As Variant
Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
DefaultEmail = WSH.RegRead("HKCR\mailto\shell\open\command\")
i = InStr(2, DefaultEmail, Chr$(34))
DefaultEmail = Mid(DefaultEmail, 2, i - 2)
'This separates the email program name from the full path
ProgPath = Split(DefaultEmail, "\")
GetDefaultEmailProgramPath = Replace(DefaultEmail, ProgPath(UBound(ProgPath)), "")
Set WSH = Nothing
End Function