Programming The VBA Editor

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

---> Adding A Procedure To A Module

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

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

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

链接是 ???

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

我自己在试着制作一张worksheet,可以提供给多人使用,为了记录每个人的修改或编辑动作,我想在excel中提取编辑者的名字以及编辑时间。因此我在GOOGLE中搜到了您的blog中曾经有介绍,链接是

遗憾的是我无法打开,系统提示说需要密码.不知是否能分享一下。谢谢!!

如何檢查文件尾？ 除了EOF之外。

我在已經打開的Word裡，尋找特定文字，但是，因為不能一次全部尋找後更換，而是要逐筆尋找，然後決定處理方式。

我讓該macro設定快速鍵，逐次執行。
為了怕執行到文件尾會進入迴圈，所以要檢查文件尾。

不知各位如何檢查？使用什麼物件或方法？

假設我做了5個按鈕如上，現在要點菜了，我按了牛肉湯和乾麵。

程式會自動印出你點的菜和價錢和總價。

可以給點提示嗎?
感謝