用mapi控件批量发送文件.htm

adsl拨号工具 有很多功能 不错啊 大家试试

      <P>End Sub<BR>Sub EmailTo()</P>
      <P>Text1(0).Text = Text1(0).Text + "邮件发送时间：" + Str(Time) + 
      vbCrLf<BR>MAPISession1.LogonUI = True<BR>MAPISession1.DownLoadMail = 
      False<BR>'test<BR>'If lpcConnections &lt;&gt; 0 Then<BR>On Error GoTo 
      error1</P>
      <P>On Error GoTo error1<BR>MAPISession1.SignOn<BR>GetText<BR>For i = 0 To 
      LineCount<BR>Call GetLine(Text1(2).hWnd, i, S)<BR>j = InStr(1, S, 
      "@")<BR>If j = 0 Then S = ""<BR>If S &lt;&gt; "" Then</P>
      <P>Debug.Print S<BR>MAPIMessages1.SessionID = 
      MAPISession1.SessionID<BR>MAPIMessages1.Compose<BR>MAPIMessages1.RecipAddress 
      = S '收信人地址<BR>MAPIMessages1.ResolveName<BR>MAPIMessages1.MsgSubject = 
      Text1(3).Text<BR>MAPIMessages1.MsgNoteText = Text1(1).Text</P>
      <P>For m = 1 To nodi<BR>MAPIMessages1.AttachmentIndex = m - 
      1<BR>MAPIMessages1.AttachmentPathName = 
      oldname(m)<BR>Next<BR>MAPIMessages1.Send<BR>End If<BR>Next</P>
      <P>Text1(0).Text = Text1(0).Text + "邮件信息：发信人名称 " + 
      MAPIMessages1.MsgOrigDisplayName + vbCrLf<BR>Text1(0).Text = Text1(0).Text 
      + "邮件信息：发信人地址 " + MAPIMessages1.MsgOrigAddress + vbCrLf<BR>Text1(0).Text = 
      Text1(0).Text + "邮件信息：发送对象共有" + Str(LineCount) + "人" + vbCrLf<BR>'End 
      If<BR>ti = Timer<BR>Me.Enabled = False<BR>MsgBox "邮件准备发送,请等待12秒"</P>
      <P>Do While Timer &lt; ti + 12 '这个语句的意义在于，让MAPI控件有足够处理信息的时间<BR>DoEvents ' 
      将控制让给其他程序。<BR>Loop<BR>Me.Enabled = True<BR>MsgBox "邮件开始发送"</P>
      <P>Me.Caption = "Outllook的批量邮件发送 ☆VB爱好者乐园 http://yingzi007.126.com☆"</P>
      <P>MAPISession1.SignOff<BR>'End If<BR>Exit Sub<BR>error1:<BR>If err = 
      48389 Then<BR>MsgBox "MAPI错误，请不要把FoxMail设为IE的默认邮件发送程序", 
      48<BR>Text1(0).Text = Text1(0) + "发送错误：把FoxMail设置为IE的默认邮件程序" + 
      vbCrLf<BR>Else<BR>MsgBox err &amp; Error(err)<BR>Text1(0).Text = Text1(0) 
      + "发送错误：" + Error(err) + vbCrLf<BR>End If<BR>End Sub</P>
      <P>Sub GetText()<BR>LineCount = SendMessageLong(Text1(2).hWnd, 
      EM_GETLINECOUNT, 0&amp;, 0&amp;)<BR>End Sub</P>
      <P>Sub newfile()<BR>ynsave<BR>If Response = 6 
      Then<BR>savefile<BR>Else<BR>TreeView1.Nodes.Remove 
      1<BR>TreeView1.Nodes.Remove 1<BR>For i = 1 To 3<BR>Text1(i).Visible = 
      False<BR>Next<BR>Set nodX = TreeView1.Nodes.Add(, , , "基本设置 ", 1)<BR>Set 
      nodX = TreeView1.Nodes.Add(1, tvwChild, , "发信内容 ", 2)<BR>Set nodX = 
      TreeView1.Nodes.Add(1, tvwChild, , "收信人地址", 3)<BR>Set nodX = 
      TreeView1.Nodes.Add(1, tvwChild, , "增加附件", 4)<BR>Set nodX = 
      TreeView1.Nodes.Add(, , , "错误提示 ", 5)<BR>Text1(1).Text = "请在这里输入信件的内容" + 
      vbCrLf + vbCrLf + "，您好！"<BR>Text1(2).Text = "# 请在这里输入你要发送的Email的地址" + 
      vbCrLf + "# 注意每个Email为一行" + vbCrLf + vbCrLf + "[e-mail]" + 
      vbCrLf + "[e-mail]"<BR>Text1(3).Text = "请在这里输入信件的主题"<BR>End 
      If<BR>End Sub</P>
      <P>Sub savefile()<BR>On Error GoTo err<BR>CommonDialog1.Flags = 
      &amp;H2<BR>CommonDialog1.Filter = 
      "Text(*.txt)|*.txt"<BR>CommonDialog1.ShowSave<BR>If CommonDialog1.FileName 
      &lt;&gt; "" Then<BR>Dim savefile(1 To 4) As String<BR>For i = 1 To 
      nodi<BR>savefile(1) = savefile(1) + "◎◎" + oldname(i) + "◎◎" + 
      vbCrLf<BR>Next<BR>savefile(2) = "○○" + Text1(3).Text + "○○"<BR>savefile(3) 
      = "●●" + Text1(1).Text + "●●"<BR>savefile(4) = "◇◇" + Text1(2).Text + 
      "◇◇"<BR>Open CommonDialog1.FileName For Output As #1<BR>Print #1, "□□□□□" 
      + vbCrLf + savefile(1) + vbCrLf + savefile(2) + vbCrLf + savefile(3) + 
      vbCrLf + savefile(4)<BR>Close #1<BR>End If<BR>Exit 
      Sub<BR>err:<BR>CommonDialog1.FileName = ""<BR>End Sub</P>
      <P>Sub openfile()<BR>ynsave<BR>If Response = 6 Then<BR>savefile<BR>End 
      If</P>
      <P>Dim StrName, StrTe, LenStrTe As String<BR>On Error GoTo 
      err<BR>CommonDialog1.Filter = 
      "Text(*.txt)|*.txt"<BR>CommonDialog1.ShowOpen<BR>StrName = 
      CommonDialog1.FileName<BR>Open StrName For Input As #1<BR>On Error GoTo 
      errfi<BR>Line Input #1, StrTe<BR>Close #1<BR>If StrTe &lt;&gt; "□□□□□" 
      Then<BR>MsgBox "文件格式错误"<BR>Exit Sub<BR>Else<BR>StrTe = ""<BR>Open StrName 
      For Input As #1<BR>StrTe = Input(LOF(1), #1)<BR>Close #1</P>
      <P><BR>End If<BR>Exit Sub<BR>err:<BR>StrName = ""</P>
      <P>Exit Sub<BR>errfi:<BR>Close #1<BR>Open StrName For Input As #1<BR>Do 
      While Not EOF(1)<BR>Line Input #1, StrTe<BR>LenStrTe = LenStrTe + StrTe + 
      vbCrLf<BR>Loop<BR>Close #1<BR>Call GetFile("○○", LenStrTe, 
      Get_File)<BR>Text1(3).Text = Get_File<BR>Call GetFile("●●", LenStrTe, 
      Get_File)<BR>Text1(1).Text = Get_File<BR>Call GetFile("◇◇", LenStrTe, 
      Get_File)<BR>Text1(2).Text = Get_File<BR>End Sub<BR>Sub GetFile(GetStr As 
      String, FullStr As String, GetStrAl As String)<BR>Dim Inte, InTem(1 To 2) 
      As Integer<BR>'Dim GetStrAl As String</P>
      <P>Inte = InStr(Inte + 1, FullStr, GetStr)<BR>InTem(1) = Inte<BR>Inte = 
      InStr(Inte + 1, FullStr, GetStr)<BR>InTem(2) = Inte</P>
      <P>GetStrAl = Mid(FullStr, InTem(1) + Len(GetStr), InTem(2) - InTem(1) - 
      Len(GetStr))</P>
      <P>End Sub</P>
      <P>Sub ynsave()<BR>Response = MsgBox("是否保存当前文件??", 4 + 32)<BR>End Sub</P>
      <P>Sub test()</P>
      <P>ReDim lprasconn95(intArraySize) As RASCONN95<BR>lprasconn95(0).dwSize = 
      412<BR>lpcb = 256 * lprasconn95(0).dwSize<BR>lngRetCode = 
      RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)</P>
      <P><BR>If lpcConnections = 0 Then<BR>MsgBox "没有拨号网络连接！", 
      vbInformation<BR>Text1(0).Text = Text1(0).Text + "发送错误：没有拨号网络连接" + 
      vbCrLf<BR>End If</P>
      <P>End Sub</P>
      <P>====以下是模块====</P>
      <P><BR>Public Declare Function SendMessageLong Lib _<BR>"user32" Alias 
      "SendMessageA" (ByVal hWnd As Long, _<BR>ByVal wMsg As Long, ByVal wParam 
      As Long, ByVal lParam As Long) As Long<BR>Public Const EM_GETLINECOUNT = 
      "&amp;HBA"</P>
      <P><BR>Public Const EM_GETLINE = &amp;HC4<BR>Public Const EM_LINELENGTH = 
      &amp;HC1<BR>Public Const EM_LINEINDEX = &amp;HBB</P>
      <P>Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" 
      (ByVal hWnd As Long, _<BR>ByVal wMsg As Long, ByVal wParam As Long, lParam 
      As Any) As Long<BR>Private Declare Sub RtlMoveMemory Lib "KERNEL32" 
      (lpvDest As Any, lpvSource As Any, ByVal _<BR>cbCopy As Long)</P>
      <P><BR>Sub GetLine(ByVal hWnd As Long, ByVal whichLine As Long, Line As 
      String)<BR>Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As 
      Long</P>
      <P>lc = SendMessage(hWnd, EM_LINEINDEX, whichLine, ByVal 0&amp;)<BR>length 
      = SendMessage(hWnd, EM_LINELENGTH, lc, ByVal 0&amp;)<BR>If length &gt; 0 
      Then<BR>ReDim bArr(length + 1) As Byte, bArr2(length - 1) As Byte<BR>Call 
      RtlMoveMemory(bArr(0), length, 2)<BR>Call SendMessage(hWnd, EM_GETLINE, 
      whichLine, bArr(0))<BR>Call RtlMoveMemory(bArr2(0), bArr(0), 
      length)<BR>Line = StrConv(bArr2, vbUnicode)<BR>Else<BR>Line = ""<BR>End 
      If<BR>End Sub</P><!-- #EndEditable --></TD></TR>
  <TR>
    <TD bgColor=#009999 height=17>
      <DIV align=center><A href="http://dreamdee.126.com/">梦蝶网</A><FONT 
      color=#ffffff>版权所有</FONT></DIV></TD></TR>
  <TR>
    <TD bgColor=#0066cc>
      <DIV align=center><A href="http://www.dreamdee.cn.gs/index.htm"><IMG 
      alt=返回首页 border=0 height=16 src="用MAPI控件批量发送文件.files/home.gif" 
      width=16></A><A href="javascript:window.close();"><IMG alt=关闭当前页 border=0 
      height=21 src="用MAPI控件批量发送文件.files/close.gif" width=100></A><A 
      href="http://www.dreamdee.cn.gs/index.htm"><IMG alt=返回首页 border=0 
      height=16 src="用MAPI控件批量发送文件.files/home.gif" 
  width=16></A></DIV></TD></TR></TBODY></TABLE><!-- #EndTemplate --></BODY></HTML>