请版主解释一下这段代码

hbkeguojin · 发表于 2009-4-7 22:55

因为要对客户发邀请信，在网上下载了一段代码，有的看得懂，有的看不懂，望版主帮忙注释这段代码：
Sub mailto()
Application.ScreenUpdating = False
Dim objOL As Object
Dim itmNewMail As Object
Dim i%, j%, k%, x%, y%
Dim strbt() As String, strsj() As String, strsum$

Set objOL = CreateObject("Outlook.Application")
Sheets(1).Activate
ActiveSheet.Range("a1").Select
Set tk = ActiveCell.CurrentRegion
k = tk.Columns.Count
j = tk.Rows.Count - 1
ReDim strbt(k)
For i = 0 To k
strbt(i) = Trim(Sheets(1).Range("a1").Offset(0, i).Value)
Next i
For x = 1 To j - 1
   If Trim(Sheets(3).Range("c" & x + 1)) <> "" Then
      Set itmNewMail = objOL.CreateItem(olMailItem)
      itmNewMail.Subject = Trim(Sheets(1).Range("a1").Offset(x, 1).Value) '& "" & Month(Date) & ""
      itmNewMail.To = Trim(Sheets(3).Range("c" & x + 1))

      For y = 0 To k
         ReDim strsj(y)
         strsj(y) = Sheets(1).Range("a1").Offset(x, y).Value
         strsum = strsum & strbt(y) & "    " & strsj(y) & vbCrLf
      Next y
      itmNewMail.body = strsum & vbNewLine & "    " '& Month(Date) & "" '& vbNewLine & Space(60) & "" ' & vbNewLine & Space(65) & Date
      itmNewMail.display
      Application.OnTime Now + TimeValue("00:00:05"), "hd"
      strsum = ""
   End If
Next x
itmNewMail.send

Set objOL = Nothing
Set itmNewMail = Nothing
Application.ScreenUpdating = True
End Sub
Sub hd()
   SendKeys "%{s}", True
End Sub
在线等，急用
把文件发上来，供参考。另我要对不同用户发内容相同的信件，可不可以群发形式发送。
附件：

hbkeguojin · 发表于 2009-4-8 22:00

本人急切希望得到大家的帮助

aaaaabbbbb · 发表于 2009-4-9 23:32

有点长，大概的意思是将SHEET1中的单元格的内容发送到SHEET3中对应的邮件地址里。

你想实现什么功能？

hbkeguojin · 发表于 2009-4-9 23:45

原帖由 aaaaabbbbb 于 2009-4-9 23:32 发表
有点长，大概的意思是将SHEET1中的单元格的内容发送到SHEET3中对应的邮件地址里。

你想实现什么功能？

是有点长。该代码是将SHEET1中的单元格的内容发送到SHEET3中对应的邮件地址里，但我现在想的是在SHEET1只将一个单元格的内容（比如C3的内容）发给SHEET3中所有的对应邮件地址里，而不是现在只能一对一发送。如C3只能发送SHEET3的第三行对应的邮件地址里。

aaaaabbbbb · 发表于 2009-4-10 22:02

试一下以下代码.

Sub mailto()
Application.ScreenUpdating = False
Dim objOL As Object
Dim itmNewMail As Object
Dim i%, j%, k%, x%, y%
Dim strbt() As String, strsj() As String, strsum$

Set objOL = CreateObject("Outlook.Application")
'------------------将邮件地址放到一起-----------
Sheets("邮件地址").Activate
rowofallmail = ActiveSheet.UsedRange.Rows.Count
For i = 2 To rowofallmail
   allmail = Range("c" & i) & ";" & allmail
Next i
'------------------------------------------------
Sheets(1).Activate
ActiveSheet.Range("a1").Select
Set tk = ActiveCell.CurrentRegion
k = tk.Columns.Count
j = tk.Rows.Count - 1
ReDim strbt(k)
For i = 0 To k
strbt(i) = Trim(Sheets(1).Range("a1").Offset(0, i).Value)
Next i
For x = 1 To j - 1
   'If Trim(Sheets(3).Range("c" & x + 1)) <> "" Then
      Set itmNewMail = objOL.CreateItem(olMailItem)
      itmNewMail.Subject = Trim(Sheets(1).Range("a1").Offset(x, 1).Value) '& "" & Month(Date) & ""
   ' itmNewMail.to = Trim(Sheets(3).Range("c" & x + 1))
      '-------发送给所有人----------
      itmNewMail.to = allmail

      '-----------
      For y = 0 To k
         ReDim strsj(y)
         strsj(y) = Sheets(1).Range("a1").Offset(x, y).Value
         strsum = strsum & strbt(y) & "    " & strsj(y) & vbCrLf
      Next y
      itmNewMail.body = strsum & vbNewLine & "    " '& Month(Date) & "" '& vbNewLine & Space(60) & "" ' & vbNewLine & Space(65) & Date
      itmNewMail.display
      Application.OnTime Now + TimeValue("00:00:05"), "hd"
      strsum = ""
   'End If
Next x
itmNewMail.send

Set objOL = Nothing
Set itmNewMail = Nothing
Application.ScreenUpdating = True
End Sub
Sub hd()
   SendKeys "%{s}", True
End Sub

hbkeguojin · 发表于 2009-4-10 23:06

原帖由 aaaaabbbbb 于 2009-4-10 22:02 发表
试一下以下代码.

Sub mailto()
Application.ScreenUpdating = False
Dim objOL As Object
Dim itmNewMail As Object
Dim i%, j%, k%, x%, y%
Dim strbt() As String, strsj() As String, ...

谢谢！下来试试。

小安 · 发表于 2010-4-2 23:46

试了一下上述附件，但只能“内容”一工作的A:Q列内容发送，如果要发送A:S列的内容，需改动哪里？谢谢！

		自动登录	找回密码
密码			免费注册

[求助] 请版主解释一下这段代码