Hi everyone,
I am looking for a way to be able to set a hyperlink to a file on our Microsoft Network. I am able to produce the link, but when I have my users click on the link, I get a Internet Explorer download message box. I would like for this to go away. Has anyone been able to do what I am asking? Here is my VBA code:
strFileName = "J:\QA\Productivity Reports\" & strTemp1 & "_" & Month(datEnd) _
& "_" & Day(datEnd) & "_" & Right(CStr(Year(datEnd)), 2) & ".xls"
xl.ActiveWorkbook.SaveAs strFileName
If strFileName <> “” Then
eml.CurrentUser = "Eric Brenner"
eml.AddEmployeeRecipient Right(GetEmployeeNameFromActiveDirectory(strTL), 5)
'eml.AddEmployeeRecipient Right(GetEmployeeNameFromActiveDirectory("Eric Brenner"), 5)
eml.AddEmployeeCarbonRecipient Right(GetEmployeeNameFromActiveDirectory("Eric Brenner"), 5)
eml.SenderEmail = "Eric_Brenner@dart.biz"
eml.Subject = "Weekly Productivity Report"
eml.BodyIsHTML = True
eml.Body = "<html><body><p><a href=" & strFileName & "> Click here." & "</a></p></body></html>"
eml.Send
Set eml = Nothing
End If
'=========================================================================================
’ Dart Automatic Emailer
’
’ Allows emails to be sent programmatically without needing MAPI or any other
’ client-side utilities. To send an email in HTML form, be sure to set the
’ BodyIsHTML property to TRUE.
’
’
’ Microsoft ActiveX Data Objects 2.6 Library
’
’
’ Set eml = New clsEmail
’
’ eml.CurrentUser = “D12345”
’ eml.AddRecipient “Jeremy_White@dart.biz”
’ eml.AddEmployeeRecipient “12345”
’ eml.SenderEmail = “Jeremy_White@dart.biz”
’ eml.Subject = “Test”
’ eml.Body = “This is only a test”
’
’ If (eml.Send) Then
’ MsgBox “Email sent OK”
’ Else
’ MsgBox “Email FAILED”
’ End If
’
’
’ For development purposes, set a conditional compilation argument as:
’
’ *** DebugVersion = 1 ***
’
’ This will cause an email not to be sent. Instead, a message box will be displayed
’ as what the email message would have been.
’
’
’ 1.06 2004-Mar-11 JMW If DartID < 0, don’t add @Dart.biz to get email
’ 1.05 2004-Feb-11 JMW Connection object opened/closed when needed
’ 1.04 2003-Mar-11 JMW If no email w/ EmpID, use D + EmpID + @Dart.biz
’ 1.03 2003-Feb-13 JMW EmpID emails displayed as “Last, First” email@dart.biz
’ 1.02 2003-Jan-17 JMW Using ShortName instead of email, b/c SMTP can’t
’ handle notes style of email addresses
’ 1.01 2003-Jan-14 JMW Changed SP, Emp ID lookup, Sender possibilities
’ 1.00 2002-Dec-20 JMW Initial Development
'=========================================================================================
Option Explicit
Private Const EML_USER = “DartEmail”
Private Const EML_PASSWORD = “”
Private Const EML_DATABASE = “DartCommon”
Private Const EML_SERVER = “SQL-2K1”
Private Const EML_PROCEDURE = “spSendEmail”
Private Const EML_ADDRESS_BOOK = “vwAddressBook”
Private Const EML_DOMAIN = “@Dart.biz”
Private Type udtEmail
Recipients() As String
SendCC() As String
SendFrom As String
Subject As String
Body As String
BodyIsHTML As Boolean
User As String
End Type
Private m_nRecipientCount As Integer
Private m_nCarbonCount As Integer
Private m_Email As udtEmail
Public Property Get CurrentUser() As String
CurrentUser = m_Email.User
End Property
Public Property Let CurrentUser(ByVal sValue As String)
m_Email.User = sValue
End Property
Public Property Get Body() As String
Body = m_Email.Body
End Property
Public Property Let Body(ByVal sValue As String)
m_Email.Body = sValue
End Property
Public Property Get BodyIsHTML() As Boolean
BodyIsHTML = m_Email.BodyIsHTML
End Property
Public Property Let BodyIsHTML(ByVal bValue As Boolean)
m_Email.BodyIsHTML = bValue
End Property
Public Property Get Sender() As String
Sender = m_Email.SendFrom
End Property
Public Property Let SenderEmail(ByVal sValue As String)
If (IsValidEmail(sValue)) Then
m_Email.SendFrom = sValue
Else
Debug.Assert False ' Not a valid email address
End If
End Property
Public Property Let SenderEmployee(ByVal sValue As String)
On Error GoTo Err_Handler
m_Email.SendFrom = GetEmailFromID(sValue)
Err_Handler:
If (Err.Number <> 0) Then
Err.Raise Err.Number, "[SenderEmployee]" & Err.Source, _
Err.Description, Err.HelpFile, Err.HelpContext
End If
End Property
Public Property Get Subject() As String
Subject = m_Email.Subject
End Property
Public Property Let Subject(ByVal sValue As String)
m_Email.Subject = sValue
End Property
Public Property Get RecipientList() As String
If (m_nRecipientCount > 0) Then
RecipientList = Join(m_Email.Recipients, ", ")
End If
End Property
Public Property Get CarbonRecipientList() As String
If (m_nCarbonCount > 0) Then
CarbonRecipientList = Join(m_Email.SendCC, ", ")
End If
End Property
'-----------------------------------------------------------------------------------------
’
’ ClearRecipients
’
’
’ Removes all recipients from the list
’
’
’ <N/A>
’
’
’ <N/A>
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Public Sub ClearRecipients()
m_nRecipientCount = 0
End Sub
'-----------------------------------------------------------------------------------------
’
’ AddRecipient
’
’
’ Adds the given email address to the Recipient list if it is a valid
’ email address.
’
’
’ sEmail - Email address to add
’
’
’ Boolean - True only if the recipient was added properly
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Public Function AddRecipient(ByVal sEmail As String) As Boolean
If IsValidEmail(sEmail) Then
' Increment the array size and resize the array
m_nRecipientCount = m_nRecipientCount + 1
ReDim Preserve m_Email.Recipients(1 To m_nRecipientCount)
' Add the email address
m_Email.Recipients(m_nRecipientCount) = sEmail
AddRecipient = True
Else
Debug.Assert False ' Invalid Email address
AddRecipient = False
End If
End Function
'-----------------------------------------------------------------------------------------
’
’ AddEmployeeRecipient
’
’
’ Looks up the email address corresponding to the EmployeeID number
’ and adds it to the Recipient list
’
’
’ sDartID - Employee Number (without D) of the person to add
’
’
’ Boolean - True only if the recipient was added properly
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Public Function AddEmployeeRecipient(ByVal sDartID As String) As Boolean
Dim sEmail As String
On Error GoTo Err_Handler
sEmail = GetEmailFromID(sDartID)
AddEmployeeRecipient = AddRecipient(sEmail)
Err_Handler:
If (Err.Number <> 0) Then
Err.Raise Err.Number, "[AddEmployeeRecipient]" & Err.Source, _
Err.Description, Err.HelpFile, Err.HelpContext
End If
End Function
'-----------------------------------------------------------------------------------------
’
’ ClearCarbonRecipients
’
’
’ Removes all carbon copy recipients from the list
’
’
’ <N/A>
’
’
’ <N/A>
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Public Sub ClearCarbonRecipients()
m_nCarbonCount = 0
End Sub
'-----------------------------------------------------------------------------------------
’
’ AddCarbonRecipient
’
’
’ Adds the given email address to the Carbon Copy Recipient list if
’ it is a valid email address.
’
’
’ sEmail - Email address to add
’
’
’ Boolean - True only if the recipient was added properly
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Public Function AddCarbonRecipient(ByVal sEmail As String) As Boolean
If IsValidEmail(sEmail) Then
' Increment the array size and resize the array
m_nCarbonCount = m_nCarbonCount + 1
ReDim Preserve m_Email.SendCC(1 To m_nCarbonCount)
' Add the email address
m_Email.SendCC(m_nCarbonCount) = sEmail
AddCarbonRecipient = True
Else
Debug.Assert False ' Invalid Email address
AddCarbonRecipient = False
End If
End Function
'-----------------------------------------------------------------------------------------
’
’ AddEmployeeCarbonRecipient
’
’
’ Looks up the email address corresponding to the EmployeeID number
’ and adds it to the Carbon Copy Recipient list
’
’
’ sDartID - Employee Number (without D) of the person to add
’
’
’ Boolean - True only if the recipient was added properly
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Public Function AddEmployeeCarbonRecipient(ByVal sDartID As String) As Boolean
Dim sEmail As String
On Error GoTo Err_Handler
sEmail = GetEmailFromID(sDartID)
AddEmployeeCarbonRecipient = AddCarbonRecipient(sEmail)
Err_Handler:
If (Err.Number <> 0) Then
Err.Raise Err.Number, "[AddEmployeeCarbonRecipient]" & Err.Source, _
Err.Description, Err.HelpFile, Err.HelpContext
End If
End Function
'-----------------------------------------------------------------------------------------
’
’ AddCarbonRecipientEx
’
’
’ Adds the given email address to the Carbon Copy Recipient list if
’ it is a valid email address.
’ or
’ Looks up the email address corresponding to the EmployeeID number
’ and adds it to the Carbon Copy Recipient list
’
’
’ vEmailOrID - Email address (String) or Employee Number (long) of the person to add
’
’
’ Boolean - True if the recipient was added properly or already in list
’
’
’ 2006-Apr-03 GAP Initial Development
'-----------------------------------------------------------------------------------------
Public Function AddCarbonRecipientEx(ByVal vEmailOrID As Variant) As Boolean
Dim sEmail As String
Dim lID As Long
Dim i As Integer
On Error GoTo Err_Handler
If IsNull(vEmailOrID) Then
AddCarbonRecipientEx = False
Exit Function
End If
'If a numeric value (Employee ID) was passed in, convert to an email address
'else use as-is
lID = CLng(vEmailOrID)
If lID > 0 Then
sEmail = GetEmailFromID(lID)
Else
sEmail = vEmailOrID
End If
'Check if CC already in Recipient list
For i = 1 To m_nRecipientCount
If sEmail = m_Email.Recipients(i) Then
AddCarbonRecipientEx = True
Exit Function
End If
Next
'Add to list
AddCarbonRecipientEx = AddCarbonRecipient(sEmail)
Err_Handler:
If (Err.Number <> 0) Then
Err.Raise Err.Number, "[AddEmployeeCarbonRecipient]" & Err.Source, _
Err.Description, Err.HelpFile, Err.HelpContext
End If
End Function
'-----------------------------------------------------------------------------------------
’
’ CreateConnection
’
’
’ Creates a connection to the server and database that has the email
’ functions and logs in it.
’
’
’ <N/A>
’
’
’ Boolean - True if the connection is created properly
’
’
’ 2004-Mar-11 GAP Added Set to CreateConnection = cn line
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Private Function CreateConnection() As ADODB.Connection
Dim sConn As String
Dim cn As ADODB.Connection
On Error GoTo Err_Handler
sConn = “DRIVER={SQL Server};” & _
"SERVER=" & EML_SERVER & ";" & _
"UID=" & EML_USER & ";" & _
"PWD=" & EML_PASSWORD & ";" & _
"DATABASE=" & EML_DATABASE & ";"
Set cn = New ADODB.Connection
cn.Open sConn
Set CreateConnection = cn
Exit Function
Err_Handler:
If (Not cn Is Nothing) Then
If (cn.State <> adStateClosed) Then
cn.Close
End If
Set cn = Nothing
End If
Err.Raise Err.Number, “[clsEmail.CreateConnection]” & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function
'-----------------------------------------------------------------------------------------
’
’ Send
’
’
’ Sends out the email based on the information provided in the class
’
’
’ <N/A>
’
’
’ Boolean - True if the connection is created properly
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Public Function Send() As Boolean
Dim cn As ADODB.Connection
Dim cmd As ADODB.Command
Dim sMsg As String
Debug.Assert m_nRecipientCount
On Error GoTo Err_Handler
’ If there is no email address, it can’t be sent
If (0 = Len(Me.RecipientList)) Then
Err.Description = “”
sMsg = "This message can not be sent because there is no valid email address to " & _
"send it to." & vbLf & vbLf & _
"User: " & Me.CurrentUser & vbLf & _
"To: " & Me.RecipientList & vbLf & _
"CC: " & Me.CarbonRecipientList & vbLf & _
"From: " & Me.Sender & vbLf & _
"Subject: " & Me.Subject & vbLf & _
"Body: " & Me.Body
MsgBox sMsg, vbExclamation + vbOKOnly, "Email Recipient Missing"
Err.Description = sMsg
Send = False
Exit Function
End If
#If (DebugVersion) Then
MsgBox "This message was not sent because the version is currently in debug mode." & _
vbLf & vbLf & _
"User: " & Me.CurrentUser & vbLf & _
"To: " & Me.RecipientList & vbLf & _
"CC: " & Me.CarbonRecipientList & vbLf & _
"From: " & Me.Sender & vbLf & _
"Subject: " & Me.Subject & vbLf & _
"Body: " & Me.Body & vbLf & _
"BodyIsHTML: " & Me.BodyIsHTML, _
, "clsEmail.Send"
Send = True
Exit Function
#End If
If Len(m_Email.User) = 0 Then
Debug.Assert False 'If no user is specified, can't track who sent the email
End If
Set cn = CreateConnection()
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cn
.CommandText = EML_PROCEDURE
.CommandType = adCmdStoredProc
.Parameters("@User").Value = Me.CurrentUser
.Parameters("@To").Value = Me.RecipientList
.Parameters("@CC").Value = Me.CarbonRecipientList
.Parameters("@From").Value = Me.Sender
.Parameters("@Subject").Value = Me.Subject
.Parameters("@Body").Value = Me.Body
.Parameters("@BodyIsHTML").Value = Me.BodyIsHTML
.Execute
' For some reason, ADO doesn't like "@RETURN_VALUE" as the paramater index. It is
' random and only happens on occasion. After looking on Google, it seems that
' using 0 more reliable as the return parameter, therefore, that's what I'm doing.
Send = .Parameters(0).Value
If .Parameters(0).Value = 0 Then
Err.Description = EML_PROCEDURE & " failed to " & Me.RecipientList
End If
End With
Err_Handler:
If Not (cmd Is Nothing) Then
Set cmd = Nothing
End If
If Not (cn Is Nothing) Then
If (cn.State = adStateOpen) Then
cn.Close
End If
Set cn = Nothing
End If
If (Err.Number <> 0) Then
Debug.Assert False ' An unexpected error occurred
Send = False
Err.Raise Err.Number, "[clsEmail.Send]" & Err.Source, Err.Description, _
Err.HelpFile, Err.HelpContext
End If
End Function
'-----------------------------------------------------------------------------------------
’
’ GetEmailFromID
’
’
’ Looks up the email address of the person with the given Employee ID
’ If the person cannot be found in the address book, their email address
’ will be in the form of D123456@Dart.biz as a last resort.
’
’
’ sDartID - The Employee ID number (w/o D) of person to look up
’
’
’ String - Email address of the employee
’
’
’ 2004-Mar-11 JMW Return “” if DartID < 0
’ 2003-Mar-11 JMW Defaults to D1234@Dart.biz type email address
’ if email address can’t be found
’ 2003-Feb-13 JMW Prepends email address with name
’ 2003-Jan-17 JMW Using short name instead of email, b/c SMTP
’ can’t handle notes style of email addresses
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Private Function GetEmailFromID(ByVal sDartID As String) As String
Dim sSQL As String
Dim sEmail As String
Dim sName As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
GetEmailFromID = “”
On Error GoTo Err_Handler
’ Check to see if Dart ID is valid # and is >= 0, o/w return blank
'If (CToNum(sDartID) < 0) Then
' Exit the sub
'Exit Function
'End If
Set cn = CreateConnection()
’ Default email address to “D” & Employee Number & “@Dart.biz”
sEmail = “D” & sDartID & EML_DOMAIN
’ Ignore cases that have Dart Notes Server as their email server
sSQL = "SELECT [Name], ShortName " & _
"FROM " & EML_ADDRESS_BOOK & " " & _
"WHERE EmployeeID = '" & sDartID & "' " & _
"AND MailServer Not Like '%Dart Notes Server%'"
Set rs = New ADODB.Recordset
rs.Open sSQL, cn, adOpenForwardOnly, adLockReadOnly
If Not (rs.EOF) Then
If Not IsNull(rs.Fields("ShortName").Value) Then
' Get short name, could be several so grab only the first one
sEmail = Trim(rs.Fields("ShortName").Value)
sName = Trim(rs.Fields("Name").Value)
If InStr(1, sEmail, " ", vbTextCompare) Then
sEmail = Left(sEmail, InStr(1, sEmail, " ", vbTextCompare) - 1)
End If
' If it's a vaild email address, use it, o/w tack on the domain
If Not IsValidEmail(sEmail) Then
sEmail = sEmail & EML_DOMAIN
End If
' Add the name to the email address
If Len(sName) Then
sEmail = """" & sName & """ <" & sEmail & ">"
End If
End If
End If
’ Return the email address
GetEmailFromID = sEmail
Err_Handler:
If Not (rs Is Nothing) Then
If (rs.State = adStateOpen) Then
rs.Close
End If
Set rs = Nothing
End If
If Not (cn Is Nothing) Then
If (cn.State = adStateOpen) Then
cn.Close
End If
Set cn = Nothing
End If
If (Err.Number <> 0) Then
Err.Raise Err.Number, "[GetEmailFromID]" & Err.Source, _
Err.Description, Err.HelpFile, Err.HelpContext
End If
End Function
'-----------------------------------------------------------------------------------------
’
’ IsValidEmail
’
’
’ Basic check to see if the email address provided appears to be valid
’
’
’ sEmail - Email address to check
’
’
’ Boolean - True if email address appears valid, o/w False
’
’
’ 2002-Dec-19 JMW Initial Development
'-----------------------------------------------------------------------------------------
Private Function IsValidEmail(ByVal sEmail As String) As Boolean
Dim nAtSymbol As Integer
Dim nDot As Integer
Dim sDomain As String
IsValidEmail = False
’ Does it have the @ symbol
nAtSymbol = InStr(1, sEmail, “@”, vbBinaryCompare)
If (nAtSymbol) Then
sDomain = Right(sEmail, (Len(sEmail) - nAtSymbol))
nDot = InStrRev(sDomain, ".", , vbBinaryCompare)
' Is there a dot in the domain (after @ symbol)
If (nDot) Then
' Is there a domain, not just top level (name before . after @)
If Len(Left(sDomain, nDot - 1)) Then
IsValidEmail = True
End If
End If
End If
End Function
Private Sub Class_Initialize()
On Error GoTo Err_Handler
m_nRecipientCount = 0
m_nCarbonCount = 0
m_Email.BodyIsHTML = True
Err_Handler:
If (Err.Number <> 0) Then
Err.Raise Err.Number, "[clsEmail.Class_Initialize]" & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub