Blakieto
07-08-2004, 05:26 PM
Hey All,
I've been working on auto-generated emails, containing data from Excel cells. This is what I have so far (a few hours of work.) I'm surprised that something like this is not built in... maybe it is and I've simply missed it?
Passed a text string (a cell containing text) this routine will replace every occurance of "=CELL(row,column)" with the contents of that Excel cell. For example, if cell(1,1) were to contain the word "Betty", then the string "Hi =CELL(1,1) How are you?" becomes "Hi Betty How are you?".
Public Function MsgSubstituteCellRefs(Msg As String) As String
' Given a string that contains items like "=CELL(1,3)", each occurance of such "cell references"
' are replaced with the contents of that Excel cell. Great for use with GenerateEmail()
Dim length As Integer
Dim i As Integer ' current location within Msg we're parsing
Dim j As Integer ' current location within cell reference we're parsing
Dim k As Integer ' scratch
Dim ci As Variant ' cell reference indexes
Dim crr As Integer ' cell reference row
Dim crc As Integer ' cell reference column
Dim cw As Integer ' current word start
Dim word As String ' current word being parsed
Dim final As String ' final msg with cell references replaced with cell values
' first get rid of any extra spaces:
Msg = Application.Trim(Msg)
length = Len(Msg)
cw = 1
For i = 1 To length
If (Mid(Msg, i, 1) = " ") Then
' we've found a word break:
If (Mid(Msg, cw, 6) = "=CELL(") Then
' we've found a cell reference:
cw = cw + 6 ' position cw just after the open bracket
For j = cw To length
If (Mid(Msg, j, 1) = ")") Then
' we've located the ending bracket
' between cw and j is our cell reference
word = Mid(Msg, cw, j - cw)
ci = Split(word, ",")
k = UBound(ci)
If (k <> 1) Then
word = "BAD_CELL_REFERENCE"
Else
crr = ci(0) ' get cell reference row
crc = ci(1) ' get cell reference column
word = Cells(crr, crc) ' resolve cell reference
End If
final = final & word & " " ' add the cell reference to the final msg
cw = j + 1
i = cw
Exit For
End If
Next j
Else
word = Mid(Msg, cw, i - cw)
final = final & word & " "
cw = i + 1
End If
End If
Next i
' pick up the last portion of the message:
If (cw <> 1) Then
final = final & Mid(Msg, cw, length)
final = Application.Trim(final)
End If
MsgSubstituteCellRefs = final
End Function
Then the above can be used with this to generate whatever email one may like:
Public Function GenerateEmail(Subject As String, Msg As String, _
Recipient As String, Addr As String, _
Optional CC As String = "", _
Optional CCAddr As String = "") As String
Dim mapi_session As MAPI.Session
Dim mapi_message As MAPI.Message
Dim mapi_recipient As MAPI.Recipient
On Error GoTo SendMailError
' Create the MAPI session.
Set mapi_session = CreateObject("MAPI.Session")
mapi_session.Logon ProfileName:="Outlook"
' Create a message.
Set mapi_message = mapi_session.Outbox.Messages.Add
mapi_message.Subject = Subject
mapi_message.Text = Msg
' Add a recipient.
Set mapi_recipient = mapi_message.Recipients.Add
mapi_recipient.Name = Recipient
mapi_recipient.Type = CdoTo
mapi_recipient.Address = "SMTP:" & Addr
' mapi_recipient.Resolve
' only process the CC logic if both the CC name and addr is present:
If ((Not IsMissing(CC)) And (Not IsMissing(CCAddr))) Then
' Add a CC entry.
Set mapi_recipient = mapi_message.Recipients.Add
mapi_recipient.Name = CC
mapi_recipient.Type = CdoCc
mapi_recipient.Address = "SMTP:" & CCAddr
' mapi_recipient.Resolve
End If
' Send the message.
mapi_message.Send ShowDialog:=False
mapi_session.Logoff
GenerateEmail = "Success"
Exit Function
SendMailError:
MsgBox "Error " & Format$(Err.Number) & " sending mail" & _
vbCrLf & Err.Description, vbExclamation, "Error"
mapi_session.Logoff
GenerateEmail = Err.Description
Exit Function
End Function
The only tricky part is that the user needs to have Outlook running or it seems to error... Plus, I want to add some formatting capabilities to MsgSubstituteCellRefs() too.
Am I redoing capabilities that are already present?
-Blakieto
I've been working on auto-generated emails, containing data from Excel cells. This is what I have so far (a few hours of work.) I'm surprised that something like this is not built in... maybe it is and I've simply missed it?
Passed a text string (a cell containing text) this routine will replace every occurance of "=CELL(row,column)" with the contents of that Excel cell. For example, if cell(1,1) were to contain the word "Betty", then the string "Hi =CELL(1,1) How are you?" becomes "Hi Betty How are you?".
Public Function MsgSubstituteCellRefs(Msg As String) As String
' Given a string that contains items like "=CELL(1,3)", each occurance of such "cell references"
' are replaced with the contents of that Excel cell. Great for use with GenerateEmail()
Dim length As Integer
Dim i As Integer ' current location within Msg we're parsing
Dim j As Integer ' current location within cell reference we're parsing
Dim k As Integer ' scratch
Dim ci As Variant ' cell reference indexes
Dim crr As Integer ' cell reference row
Dim crc As Integer ' cell reference column
Dim cw As Integer ' current word start
Dim word As String ' current word being parsed
Dim final As String ' final msg with cell references replaced with cell values
' first get rid of any extra spaces:
Msg = Application.Trim(Msg)
length = Len(Msg)
cw = 1
For i = 1 To length
If (Mid(Msg, i, 1) = " ") Then
' we've found a word break:
If (Mid(Msg, cw, 6) = "=CELL(") Then
' we've found a cell reference:
cw = cw + 6 ' position cw just after the open bracket
For j = cw To length
If (Mid(Msg, j, 1) = ")") Then
' we've located the ending bracket
' between cw and j is our cell reference
word = Mid(Msg, cw, j - cw)
ci = Split(word, ",")
k = UBound(ci)
If (k <> 1) Then
word = "BAD_CELL_REFERENCE"
Else
crr = ci(0) ' get cell reference row
crc = ci(1) ' get cell reference column
word = Cells(crr, crc) ' resolve cell reference
End If
final = final & word & " " ' add the cell reference to the final msg
cw = j + 1
i = cw
Exit For
End If
Next j
Else
word = Mid(Msg, cw, i - cw)
final = final & word & " "
cw = i + 1
End If
End If
Next i
' pick up the last portion of the message:
If (cw <> 1) Then
final = final & Mid(Msg, cw, length)
final = Application.Trim(final)
End If
MsgSubstituteCellRefs = final
End Function
Then the above can be used with this to generate whatever email one may like:
Public Function GenerateEmail(Subject As String, Msg As String, _
Recipient As String, Addr As String, _
Optional CC As String = "", _
Optional CCAddr As String = "") As String
Dim mapi_session As MAPI.Session
Dim mapi_message As MAPI.Message
Dim mapi_recipient As MAPI.Recipient
On Error GoTo SendMailError
' Create the MAPI session.
Set mapi_session = CreateObject("MAPI.Session")
mapi_session.Logon ProfileName:="Outlook"
' Create a message.
Set mapi_message = mapi_session.Outbox.Messages.Add
mapi_message.Subject = Subject
mapi_message.Text = Msg
' Add a recipient.
Set mapi_recipient = mapi_message.Recipients.Add
mapi_recipient.Name = Recipient
mapi_recipient.Type = CdoTo
mapi_recipient.Address = "SMTP:" & Addr
' mapi_recipient.Resolve
' only process the CC logic if both the CC name and addr is present:
If ((Not IsMissing(CC)) And (Not IsMissing(CCAddr))) Then
' Add a CC entry.
Set mapi_recipient = mapi_message.Recipients.Add
mapi_recipient.Name = CC
mapi_recipient.Type = CdoCc
mapi_recipient.Address = "SMTP:" & CCAddr
' mapi_recipient.Resolve
End If
' Send the message.
mapi_message.Send ShowDialog:=False
mapi_session.Logoff
GenerateEmail = "Success"
Exit Function
SendMailError:
MsgBox "Error " & Format$(Err.Number) & " sending mail" & _
vbCrLf & Err.Description, vbExclamation, "Error"
mapi_session.Logoff
GenerateEmail = Err.Description
Exit Function
End Function
The only tricky part is that the user needs to have Outlook running or it seems to error... Plus, I want to add some formatting capabilities to MsgSubstituteCellRefs() too.
Am I redoing capabilities that are already present?
-Blakieto