[求助]发现很多的邮件发送只能发送全部工作簿，而不能发送当前选中的工作表

secowu

Sub CDO_Send_ActiveSheet_Body() ' This example use late binding, you don't have to set a reference ' You must be online when you run the sub Dim iMsg As Object Dim iConf As Object ' Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration")

' iConf.Load -1 ' CDO Source Defaults ' Set Flds = iConf.Fields ' With Flds ' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Fill in your SMTP server here" ' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 ' .Update ' End With

'Check out the Tips section if you want to change the .To and .TextBody With iMsg Set .Configuration = iConf '调试到这里说是变量未定义，iConf=Nothing .To = "samples@123.COM" .CC = "" .BCC = "" .From = """Ron"" <samples@123.com>" .Subject = "This is a test" .HTMLBody = SheetToHTML(ActiveSheet) .Send End With

Set iMsg = Nothing Set iConf = Nothing End Sub

secowu

龙III大哥，帮我看看你的代码为什么在我这里没有效果

另外，看看上面的代码怎样修改才能有用？

secowu

没有啊，我就试着去单步运行，也没有发现有产生新的文件，

OE 和OE 2003我都有设置的，可以收发邮件

我是将代码这样写的

Private Sub CommandButton3_Click() '发送电邮 Dim strDate As String ActiveSheet.Copy '当前工作表复制出去 strDate = Format(Date, "dd-mm-yy") & " " & Format(Time, "h-mm-ss") '根据时间给这个新建工作簿另存 ActiveWorkbook.SendMail [g6].Value, "Subject_line" '发送这个另存的，邮箱和标题 ActiveWorkbook.ChangeFileAccess xlReadOnly '更改这个新建工作簿为可读 Kill ActiveWorkbook.FullName '删除这个新建工作簿 ActiveWorkbook.Close False '不保存就关闭它，这样新建的工作簿会被直接删除哦不会留下痕迹

'Call Mail_ActiveSheet

End Sub

难道这样写的有问题吗？

secowu

以下是引用Long_III在2005-9-8 11:42:43的发言：

13的代码我这里也不行，说SheetToHTML没定义

用我给你的代码，你说运行不了，它会产生一个新的工作簿吗？

我给你SheetToHtml的代码：

Public Function SheetToHTML(sh As Worksheet) 'Function from Dick Kusleika his site 'http://www.dicks-clicks.com/excel/sheettohtml.htm 'Changed by Ron de Bruin 04-Nov-2003 Dim TempFile As String Dim Nwb As Workbook Dim myshape As Shape Dim fso As Object Dim ts As Object sh.Copy Set Nwb = ActiveWorkbook For Each myshape In Nwb.Sheets(1).Shapes myshape.Delete Next TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" Nwb.SaveAs TempFile, xlHtml Nwb.Close False Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) SheetToHTML = ts.ReadAll ts.Close Set ts = Nothing Set fso = Nothing Set Nwb = Nothing Kill TempFile End Function

secowu

谢谢，龙III大哥

为什么我用你那成功的附件也是点击了那个按钮，

还是没有反应呢？

我将OutLook Express 和 OutLook 2003 全都配置好了，

还全部开着

怎么点那个按钮也是没见着有什么在发送邮件的动作呀

secowu

以下是引用secowu在2005-9-8 9:18:40的发言：

当我们选择

1的时候，只能发送整个工作簿

2的时候，会导致文件变得非常大，甚至99%会让OE崩溃

为什么没有来个3

“以附件形式发送当前工作表”呢？

记得有个老外的程序，是可以选择的，但老是报错，说没有OE，咱的可是OE OE 2003都装了的呀

file:///c:\2.jpg

顺便将文件弄上来了，我将XLA做成了XLS，好让大家研究下。。。。

龙III兄：

你的那个附件，我怎么测试都不行，用这个老是说OUTLOOK无效

可是我的两个OE都可以正常收发邮件，又有联系人，怎么回是这样呢？

secowu

程序执行到这一步

出错，退出

If Not ApplicationIsAvailable("Outlook.Application") Then MsgBox "Outlook is not Available on this system, you can't use this Add-in.", _ vbOKOnly, "SendMail" ThisWorkbook.Close False Exit Sub End If

是7楼的提示

If Val(Application.Version) < 9 Then MsgBox "You must run Office 2000 or higher, you can't use this Add-in.", _ vbOKOnly, "SendMail" ThisWorkbook.Close False Exit Sub End If

从这知道，是可以支持2003的

检查了OE设置没问题的，不知别的高手试过没有？

会不会出现同样的错误

secowu

在别的机子上，测试可以，

删除OE组件，删除OE 2003

重新安装，还是同样问题

看来是OE的配置文件错误

＝＝＝＝＝有没有单独修复OE的配置文件的软件？找了下，好像没有，难道得重装系统？

secowu

花了1个小时,重装系统后,

接着安装了OFFICE 2003

未配置OE

接着执行Send EMAIL

能够调用OE

接着配置OE

再打开文件

就报错了.结果与7楼的一样

真晕

secowu

将龙III大哥的也试过了,还是点了那个没有反应

真不知道是什么问题了.....