用mapi收发邮件.frm

VB网络应用,例如:聊天系统,浏览器程序

Private Sub exit_Click()
End
End Sub

Private Sub faso_Click()
EmailTo
End Sub

Private Sub Form_Load()
For i = 0 To 3
Text1(i).Visible = False
Next
Set nodX = TreeView1.Nodes.Add(, , , "基本设置 ", 1)
Set nodX = TreeView1.Nodes.Add(1, tvwChild, , "发信内容 ", 2)
Set nodX = TreeView1.Nodes.Add(1, tvwChild, , "收信人地址", 3)
Set nodX = TreeView1.Nodes.Add(1, tvwChild, , "增加附件", 4)
Set nodX = TreeView1.Nodes.Add(, , , "信息提示 ", 5)
Text1(1).Text = "请在这里输入信件的内容" + vbCrLf + vbCrLf + "，您好！"
Text1(2).Text = "# 请在这里输入你要发送的Email的地址" + vbCrLf + "# 注意每个Email为一行" + vbCrLf + vbCrLf + "[e-mail]" + vbCrLf + "[e-mail]"
Text1(0).Text = "软件运行时间：" + Str(Time) + vbCrLf
End Sub


Private Sub new_Click()
newfile
End Sub

Private Sub open_Click()
openfile
End Sub

Private Sub save_Click()
savefile
End Sub


Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyA And Shift = vbCtrlMask Then
Text1(Index).SelStart = 0
Text1(Index).SelLength = Len(Text1(Index).Text)
End If

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
    Case Is = "new"
    newfile
    Case Is = "open"
    openfile
    Case Is = "save"
    savefile
    Case Is = "mato"
    EmailTo
    
End Select
End Sub

Private Sub TreeView1_Click()
On Error Resume Next
iIndex = TreeView1.SelectedItem.Index
Select Case iIndex
Case 1
For i = 0 To 3
Text1(i).Visible = False
Next

Case 2
For i = 0 To 3
Text1(i).Visible = False
Next
Text1(1).Visible = True
Text1(3).Visible = True
Case 3
For i = 0 To 3
Text1(i).Visible = False
Next
Text1(2).Visible = True
Case 5
For i = 0 To 3
Text1(i).Visible = False
Next
Text1(0).Visible = True
End Select
End Sub

Sub add_tools()
Dim i, j As Integer
i = 1
j = 1
On Error GoTo err
CommonDialog1.ShowOpen
finame = CommonDialog1.FileName
oldname(nodi) = finame
If finame <> "" Then
While i <> 0
i = InStr(i + 1, finame, "\")
If i <> 0 Then
j = i
End If
Wend
finame = Right(finame, Len(finame) - j)
Set nodX = TreeView1.Nodes.Add(4, tvwChild, , finame, 11)
finame = ""
End If
Exit Sub
err:
finame = ""
End Sub

Private Sub TreeView1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

Dim nod As Node

If Button = vbRightButton Then    '检测鼠标的点击

Set nod = TreeView1.HitTest(x, y) '返回你所点击的Node对象的坐标

On Error GoTo EmptyNode

nod.Selected = True  ' 设置你所点击的Node对象被选中

On Error GoTo 0

'<<下面是你的自定义菜单>>
If iIndex > 5 Then deltools.Visible = True

Me.PopupMenu mymenu

deltools.Visible = False

EmptyNode:

On Error GoTo 0

End If

End Sub

Sub add_email()
On Error GoTo err
CommonDialog1.Filter = "Text(*.txt)|*.txt"
CommonDialog1.ShowOpen
finame = CommonDialog1.FileName
If FileLen(finame) < 1024 * 10 Then
Text1(2).Text = ""
On Error GoTo file
Open finame For Input As #1
linetex = Input(LOF(1), #1)
Text1(2).Text = linetex
Close #1
Else
MsgBox "文件过大，装载失败！！"
End If


Exit Sub
err:
finame = ""

Exit Sub
file:
Close #1
Open finame For Input As #1
Do While Not EOF(1)
Line Input #1, linetex
Text1(2).Text = Text1(2).Text + linetex + vbCrLf
Loop
Close #1
End Sub

Sub add_file()

On Error GoTo err
CommonDialog1.Filter = "Text(*.txt)|*.txt"
CommonDialog1.ShowOpen
finame = CommonDialog1.FileName
If FileLen(finame) < 1024 * 10 Then
Text1(1).Text = ""
On Error GoTo file
Open finame For Input As #1
linetex = Input(LOF(1), #1)
Text1(1).Text = linetex
Close #1
Else
MsgBox "文件过大，装载失败！！"
End If


Exit Sub
err:
finame = ""

Exit Sub
file:
Close #1
Open finame For Input As #1
Do While Not EOF(1)
Line Input #1, linetex
Text1(1).Text = Text1(1).Text + linetex + vbCrLf
Loop
Close #1

End Sub
Sub EmailTo()

Text1(0).Text = Text1(0).Text + "邮件发送时间：" + Str(Time) + vbCrLf
MAPISession1.LogonUI = True
MAPISession1.DownLoadMail = False
'test
'If lpcConnections <> 0 Then
On Error GoTo error1

On Error GoTo error1
MAPISession1.SignOn
GetText
For i = 0 To LineCount
Call GetLine(Text1(2).hWnd, i, S)
j = InStr(1, S, "@")
If j = 0 Then S = ""
If S <> "" Then

Debug.Print S
MAPIMessages1.SessionID = MAPISession1.SessionID
MAPIMessages1.Compose
MAPIMessages1.RecipAddress = S '收信人地址
MAPIMessages1.ResolveName
MAPIMessages1.MsgSubject = Text1(3).Text
MAPIMessages1.MsgNoteText = Text1(1).Text

For m = 1 To nodi
MAPIMessages1.AttachmentIndex = m - 1
MAPIMessages1.AttachmentPathName = oldname(m)
Next
MAPIMessages1.Send
End If
Next

Text1(0).Text = Text1(0).Text + "邮件信息：发信人名称 " + MAPIMessages1.MsgOrigDisplayName + vbCrLf
Text1(0).Text = Text1(0).Text + "邮件信息：发信人地址 " + MAPIMessages1.MsgOrigAddress + vbCrLf
Text1(0).Text = Text1(0).Text + "邮件信息：发送对象共有" + Str(LineCount) + "人" + vbCrLf
'End If
ti = Timer
Me.Enabled = False
MsgBox "邮件准备发送,请等待12秒"

Do While Timer < ti + 12  '这个语句的意义在于，让MAPI控件有足够处理信息的时间
        DoEvents    ' 将控制让给其他程序。
Loop
Me.Enabled = True
MsgBox "邮件开始发送"

Me.Caption = "Outllook的批量邮件发送 ☆VB爱好者乐园 http://yingzi007.126.com☆"

MAPISession1.SignOff
'End If
Exit Sub
error1:
If err = 48389 Then
MsgBox "MAPI错误，请不要把FoxMail设为IE的默认邮件发送程序", 48
Text1(0).Text = Text1(0) + "发送错误：把FoxMail设置为IE的默认邮件程序" + vbCrLf
Else
MsgBox err & Error(err)
Text1(0).Text = Text1(0) + "发送错误：" + Error(err) + vbCrLf
End If
End Sub

Sub GetText()
LineCount = SendMessageLong(Text1(2).hWnd, EM_GETLINECOUNT, 0&, 0&)
End Sub

Sub newfile()
ynsave
If Response = 6 Then
savefile
Else
TreeView1.Nodes.Remove 1
TreeView1.Nodes.Remove 1
For i = 1 To 3
Text1(i).Visible = False
Next
Set nodX = TreeView1.Nodes.Add(, , , "基本设置 ", 1)
Set nodX = TreeView1.Nodes.Add(1, tvwChild, , "发信内容 ", 2)
Set nodX = TreeView1.Nodes.Add(1, tvwChild, , "收信人地址", 3)
Set nodX = TreeView1.Nodes.Add(1, tvwChild, , "增加附件", 4)
Set nodX = TreeView1.Nodes.Add(, , , "错误提示 ", 5)
Text1(1).Text = "请在这里输入信件的内容" + vbCrLf + vbCrLf + "，您好！"
Text1(2).Text = "# 请在这里输入你要发送的Email的地址" + vbCrLf + "# 注意每个Email为一行" + vbCrLf + vbCrLf + "[e-mail]" + vbCrLf + "[e-mail]"
Text1(3).Text = "请在这里输入信件的主题"
End If
End Sub

Sub savefile()
On Error GoTo err
CommonDialog1.Flags = &H2
CommonDialog1.Filter = "Text(*.txt)|*.txt"
CommonDialog1.ShowSave
If CommonDialog1.FileName <> "" Then
Dim savefile(1 To 4) As String
For i = 1 To nodi
savefile(1) = savefile(1) + "◎◎" + oldname(i) + "◎◎" + vbCrLf
Next
savefile(2) = "○○" + Text1(3).Text + "○○"
savefile(3) = "●●" + Text1(1).Text + "●●"
savefile(4) = "◇◇" + Text1(2).Text + "◇◇"
Open CommonDialog1.FileName For Output As #1
Print #1, "□□□□□" + vbCrLf + savefile(1) + vbCrLf + savefile(2) + vbCrLf + savefile(3) + vbCrLf + savefile(4)
Close #1
End If
Exit Sub
err:
CommonDialog1.FileName = ""
End Sub

Sub openfile()
ynsave
If Response = 6 Then
savefile
End If

Dim StrName, StrTe, LenStrTe As String
On Error GoTo err
CommonDialog1.Filter = "Text(*.txt)|*.txt"
CommonDialog1.ShowOpen
StrName = CommonDialog1.FileName
Open StrName For Input As #1
On Error GoTo errfi
Line Input #1, StrTe
Close #1
If StrTe <> "□□□□□" Then
MsgBox "文件格式错误"
Exit Sub
Else
StrTe = ""
Open StrName For Input As #1
StrTe = Input(LOF(1), #1)
Close #1



End If
Exit Sub
err:
StrName = ""

Exit Sub
errfi:
Close #1
Open StrName For Input As #1
Do While Not EOF(1)
Line Input #1, StrTe
LenStrTe = LenStrTe + StrTe + vbCrLf
Loop
Close #1
Call GetFile("○○", LenStrTe, Get_File)
Text1(3).Text = Get_File
Call GetFile("●●", LenStrTe, Get_File)
Text1(1).Text = Get_File
Call GetFile("◇◇", LenStrTe, Get_File)
Text1(2).Text = Get_File
End Sub
Sub GetFile(GetStr As String, FullStr As String, GetStrAl As String)
Dim Inte, InTem(1 To 2) As Integer
'Dim GetStrAl As String

Inte = InStr(Inte + 1, FullStr, GetStr)
InTem(1) = Inte
Inte = InStr(Inte + 1, FullStr, GetStr)
InTem(2) = Inte

GetStrAl = Mid(FullStr, InTem(1) + Len(GetStr), InTem(2) - InTem(1) - Len(GetStr))

End Sub

Sub ynsave()
Response = MsgBox("是否保存当前文件??", 4 + 32)
End Sub

Sub test()

ReDim lprasconn95(intArraySize) As RASCONN95
lprasconn95(0).dwSize = 412
lpcb = 256 * lprasconn95(0).dwSize
lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)


If lpcConnections = 0 Then
MsgBox "没有拨号网络连接！", vbInformation
Text1(0).Text = Text1(0).Text + "发送错误：没有拨号网络连接" + vbCrLf
End If

End Sub