thx very useful !

cliff : i have the VBA scripts (usually update) in the cells of excel.I need to copy and paste the range of cell into the module.Do you have any VBA scripts that can have a fast way? Thank you very much!

Programming The VBA Editor

http://www.cpearson.com/excel/vbe.aspx

---> Adding A Procedure To A Module

i have the VBA scripts (usually update) in the cells of excel.
I need to copy and paste the range of cell into the module.
Do you have any VBA scripts that can have a fast way? Thank you very much!

Can you post question in ExcelHelp with attachment and data. Thanks

Thx very useful!

I want to ask one question

If each row in excel for one email, I want to set column H to column K as the email body, how can i set the range and use the function of RangetoHTML

My code is here can u give me some idea how to write

Sub email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range, FileCell As Range, rng As Range, ck As Range
Dim strbody As String
Dim sh As Worksheet
Set sh = Sheets("Sheet1")
Set ck = sh.Cells(cell.Row, 1).Range("H1:K1")
strbody = sh.Cells(cell.Row, "H").Value & "
" & _
sh.Cells(cell.Row, "I").Value & "
" & _
sh.Cells(cell.Row, "J").Value & "


" & _
sh.Cells(cell.Row, "K").Value & "



"

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("F1:G1")
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "D").Value) = "y" Then
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = "Application for the " & Cells(cell.Row, "B").Value
.HTMLBody = strbody & RangetoHTML(ck)
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) "" Then
If Dir(FileCell.Value) "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display
.Send
End With
End If
End If
Next cell

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Emily :
ExcelHome, OfficeFans 有破密码帖子, 自己找

已在ExcelHome里找到，谢谢指教!!

http://www.thecodecage.com/forumz/excel-vba-programming/135905-outlook-body-text-bold.html

How to set the text format (Bold and underline) in email body to a particular cells (Cell J only) ?

some suggests the function to me but dunno how to merge the function into the vba code

the vba code is below:

Sub email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range, FileCell As Range, rng As Range
Dim strbody As String
Dim sh As Worksheet
Set sh = Sheets("Sheet1")
For Each cell In Range("E1:E25")
strbody = strbody & cell.Value & vbNewLine
Next
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.Cells(cell.Row, 1).Range("F1:G1")
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "D").Value) = "y" Then
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = "Application for the " & Cells(cell.Row, "B").Value
.Body = Cells(cell.Row, "H").Value & vbNewLine & Cells(cell.Row, "I").Value & vbNewLine _
& Cells(cell.Row, "J").Value & vbNewLine & Cells(cell.Row, "K").Value & vbNewLine _
& Cells(cell.Row, "L").Value & vbNewLine & Cells(cell.Row, "M").Value & vbNewLine _
& Cells(cell.Row, "N").Value & vbNewLine & Cells(cell.Row, "O").Value & vbNewLine _
& Cells(cell.Row, "P").Value & vbNewLine & Cells(cell.Row, "Q").Value & vbNewLine _
& Cells(cell.Row, "R").Value & vbNewLine & Cells(cell.Row, "S").Value & vbNewLine _
& Cells(cell.Row, "T").Value & vbNewLine & Cells(cell.Row, "U").Value & vbNewLine _
& Cells(cell.Row, "V").Value & vbNewLine & Cells(cell.Row, "W").Value & vbNewLine _
& Cells(cell.Row, "X").Value & vbNewLine & Cells(cell.Row, "Y").Value & vbNewLine _
& Cells(cell.Row, "Z").Value & vbNewLine & Cells(cell.Row, "AA").Value & vbNewLine _
& Cells(cell.Row, "AB").Value & vbNewLine & Cells(cell.Row, "AC").Value & vbNewLine _
& Cells(cell.Row, "AD").Value & vbNewLine & Cells(cell.Row, "AE").Value & vbNewLine _
& Cells(cell.Row, "AF").Value & vbNewLine & Cells(cell.Row, "AG").Value & vbNewLine _
& Cells(cell.Row, "AH").Value & vbNewLine & Cells(cell.Row, "AI").Value & vbNewLine _
& Cells(cell.Row, "AJ").Value & vbNewLine & Cells(cell.Row, "AK").Value & vbNewLine _
& Cells(cell.Row, "AL").Value & vbNewLine & Cells(cell.Row, "AM").Value & vbNewLine _
& Cells(cell.Row, "AO").Value & vbNewLine & Cells(cell.Row, "AP").Value & vbNewLine _
& Cells(cell.Row, "AQ").Value & vbNewLine

For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) "" Then
If Dir(FileCell.Value) "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display
.Send
End With
End If
End If
Next cell

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

hi

Clare :
Emily,您好.
我自己在试着制作一张worksheet,可以提供给多人使用,为了记录每个人的修改或编辑动作,我想在excel中提取编辑者的名字以及编辑时间。因此我在GOOGLE中搜到了您的blog中曾经有介绍,链接是
遗憾的是我无法打开,系统提示说需要密码.不知是否能分享一下。谢谢!!

链接是 ???

ExcelHome, OfficeFans 有破密码帖子, 自己找