分享
 
 
 

用VB实现一个简单的ESMTP客户端

王朝vb·作者佚名  2006-01-09
窄屏简体版  字體: |||超大  

最近发现JMail居然没有for VB的例子,本来想用C#写一个的,可是家里的电脑只有一个VB,好的程序员是不能受制于开发工具的(虽然我并不是个程序员)。

花了一个晚上,面对着RFC0821和Ethereal的截包结果,功夫不负有心人,终于有一个简单的例子可以和大家共享了,希望大家讨论一下。(格式不怎么好,许多异常也没处理,另外VB的语法已经忘得差不多了,请大家谅解!)

项目包括两个文件

1 main.frm

VERSION 5.00

Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"

Begin VB.Form Form1

Caption = "Form1"

ClientHeight = 4725

ClientLeft = 60

ClientTop = 345

ClientWidth = 5550

LinkTopic = "Form1"

ScaleHeight = 4725

ScaleWidth = 5550

StartUpPosition = 3 'Windows Default

Begin MSWinsockLib.Winsock smtpClient

Left = 1680

Top = 120

_ExtentX = 741

_ExtentY = 741

_Version = 393216

RemoteHost = "mail.domain.com"

RemotePort = 25

End

Begin VB.CommandButton Command2

Caption = "Connect"

Height = 495

Left = 120

TabIndex = 3

Top = 120

Width = 1215

End

Begin VB.CommandButton Command1

Caption = "Send"

Height = 375

Left = 4560

TabIndex = 2

Top = 4200

Width = 855

End

Begin VB.TextBox Text2

Height = 315

Left = 120

TabIndex = 1

Top = 4200

Width = 4215

End

Begin VB.TextBox Text1

Height = 3255

Left = 120

MultiLine = -1 'True

ScrollBars = 2 'Vertical

TabIndex = 0

Top = 840

Width = 5295

End

End

Attribute VB_Name = "Form1"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

Private state As Integer

Private FLAG_LINE_END As String

Private FLAG_MAIL_END As String

Private Sub Command1_Click()

Text2.Text = base64encode(utf16to8(Text2.Text))

'Text2.Text = base64decode(utf8to16(Text2.Text))

End Sub

Private Sub Command2_Click()

state = 0

smtpClient.Close

smtpClient.Connect

End Sub

Private Sub Form_Load()

mailcount = 2

FLAG_LINE_END = Chr(13) + Chr(10)

FLAG_MAIL_END = FLAG_LINE_END + "." + FLAG_LINE_END

End Sub

Private Sub Form_Terminate()

smtpClient.Close

End Sub

Private Sub smtpClient_Close()

'MsgBox "closed!"

state = 0

End Sub

Private Sub smtpClient_DataArrival(ByVal bytesTotal As Long)

Dim s As String

smtpClient.GetData s

Text1.Text = Text1.Text + s + FLAG_LINE_END

Dim msgHead As String

msgHead = Left(s, 3)

Dim msgBody As String

msgBody = Mid(s, 5)

Dim msgType As Integer

msgType = CInt(msgHead)

Dim msgsend As String

Select Case state

Case 0 'start state

Select Case msgType

Case 220

msgsend = "EHLO yourname" + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

state = 1

Case 421 'Service not available

End Select

Case 1 'EHLO

Select Case msgType

Case 250

msgsend = "AUTH LOGIN" + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

state = 2

Case 500, 501, 504, 421 'error happened

End Select

Case 2 'AUTH LOGIN

Select Case msgType

Case 334

If msgBody = "VXNlcm5hbWU6" + FLAG_LINE_END Then

msgsend = base64encode(utf16to8("username")) + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

ElseIf msgBody = "UGFzc3dvcmQ6" + FLAG_LINE_END Then

msgsend = base64encode(utf16to8("password")) + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

End If

Case 235 'correct

SetFrom "you@domain.com"

state = 3

Case 535 'incorrect

Quit

state = 7

Case Else

End Select

Case 3 'FROM

Select Case msgType

Case 250

SetRcpt "rpct@domain.com"

state = 4

Case 221

Quit

state = 7

Case 573

Quit

state = 7

Case 552, 451, 452 'failed

Case 500, 501, 421 'error

End Select

Case 4 'RCPT

Select Case msgType

Case 250, 251 'user is ok

msgsend = "DATA" + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

state = 5

Case 550, 551, 552, 553, 450, 451, 452 'failed

Quit

state = 7

Case 500, 501, 503, 421 'error

Quit

state = 7

End Select

Case 5 'DATA been sent

Select Case msgType

Case 354

Send "from", "to", "no subject", "plain", "test"

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

state = 6

Case 451, 554

Case 500, 501, 503, 421

End Select

Case 6 'body been sent

Select Case msgType

Case 250

Quit

state = 7

Case 552, 451, 452

Case 500, 501, 502, 421

End Select

Case 7

Select Case msgType

Case 221 'process disconnected

state = 0

Case 500 'command error

End Select

End Select

End Sub

Private Sub Quit()

Dim msgsend As String

rs.Close

conn.Close

msgsend = "QUIT" + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

End Sub

Private Sub Send(from As String, to1 As String, subject As String, ctype As String, content As String)

Dim msgsend As String

msgsend = "From: " + from + FLAG_LINE_END

msgsend = msgsend + "To: " + to1 + FLAG_LINE_END

msgsend = msgsend + "Subject: " + subject + FLAG_LINE_END

msgsend = msgsend + "Date: " + CStr(Now) + FLAG_LINE_END

msgsend = msgsend + "MIME-Version: 1.0" + FLAG_LINE_END

msgsend = msgsend + "Content-Type: text/" + ctype + ";charset=gb2312" + FLAG_LINE_END

'msgSend = msgSend + "Content-Transfer-Encoding: base64" + flag_line_end

msgsend = msgsend + content + FLAG_LINE_END

smtpClient.SendData msgsend

smtpClient.SendData FLAG_MAIL_END

End Sub

Private Sub SetFrom(from As String)

msgsend = "MAIL FROM: <" + from + ">" + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

End Sub

Private Sub SetRcpt(rcpt As String)

Dim msgsend As String

msgsend = "RCPT TO: <" + rcpt + ">" + FLAG_LINE_END

smtpClient.SendData msgsend

Text1.Text = Text1.Text + msgsend + FLAG_LINE_END

End Sub

Private Sub smtpClient_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)

MsgBox Description

End Sub

2 func.bas

Attribute VB_Name = "Module1"

Private base64EncodeChars As String

Private base64DecodeChars(127) As Integer

Function base64encode(str As String) As String

base64EncodeChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

Dim out, i, len1

Dim c1, c2, c3

len1 = Len(str)

i = 0

out = ""

While i < len1

c1 = Asc(Mid(str, i + 1, 1))

i = i + 1

If (i = len1) Then

out = out + Mid(base64EncodeChars, c1 \ 4 + 1, 1)

out = out + Mid(base64EncodeChars, (c1 And 3) * 16 + 1, 1)

out = out + "=="

base64encode = out

Exit Function

End If

c2 = Asc(Mid(str, i + 1, 1))

i = i + 1

If (i = len1) Then

out = out + Mid(base64EncodeChars, c1 \ 4 + 1, 1)

out = out + Mid(base64EncodeChars, (((c1 And 3) * 16) Or ((c2 And 240) \ 16)) + 1, 1)

out = out + Mid(base64EncodeChars, (c2 And 15) * 4 + 1, 1)

out = out + "="

base64encode = out

Exit Function

End If

c3 = Asc(Mid(str, i + 1, 1))

i = i + 1

out = out + Mid(base64EncodeChars, c1 \ 4 + 1, 1)

out = out + Mid(base64EncodeChars, (((c1 And 3) * 16) Or ((c2 And 240) \ 16)) + 1, 1)

out = out + Mid(base64EncodeChars, (((c2 And 15) * 4) Or ((c3 And 192) \ 64)) + 1, 1)

out = out + Mid(base64EncodeChars, (c3 And 63) + 1, 1)

Wend

base64encode = out

End Function

Function base64decode(str As String) As String

For i = 0 To 127

base64DecodeChars(i) = -1

Next

base64DecodeChars(43) = 62

base64DecodeChars(47) = 63

For i = 48 To 57

base64DecodeChars(i) = i + 4

Next

For i = 65 To 90

base64DecodeChars(i) = i - 65

Next

For i = 97 To 122

base64DecodeChars(i) = i - 71

Next

Dim c1, c2, c3, c4

Dim len1, out

len1 = Len(str)

i = 0

out = ""

While (i < len1)

Do

c1 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255)

i = i + 1

Loop While (i < len1 And c1 = -1)

If (c1 = -1) Then

base64decode = out

Exit Function

End If

Do

c2 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255)

i = i + 1

Loop While (i < len1 And c2 = -1)

If (c2 = -1) Then

base64decode = out

Exit Function

End If

out = out + Chr((c1 * 4) Or ((c2 And 48) \ 16))

Do

c3 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255)

i = i + 1

If (c3 = 61) Then

base64decode = out

c3 = base64DecodeChars(c3)

End If

Loop While (i < len1 And c3 = -1)

If (c3 = -1) Then

base64decode = out

Exit Function

End If

out = out + Chr(((c2 And 15) * 16) Or ((c3 And 60) \ 4))

Do

c4 = base64DecodeChars(Asc(Mid(str, i + 1, 1)) And 255)

i = i + 1

If (c4 = 61) Then

base64decode = out

c4 = base64DecodeChars(c4)

End If

Loop While (i < len1 And c4 = -1)

If (c4 = -1) Then

base64decode = out

Exit Function

End If

out = out + Chr(((c3 And 3) * 64) Or c4)

Wend

base64decode = out

End Function

Function utf16to8(str As String) As String

Dim out, i, len1, c

out = ""

len1 = Len(str)

For i = 1 To len1

c = Asc(Mid(str, i, 1))

If ((c >= 1) And (c <= 127)) Then

out = out + Mid(str, i, 1)

ElseIf (c > 2047) Then

out = out + Chr(224 Or ((c \ 4096) And 15))

out = out + Chr(128 Or ((c \ 64) And 63))

out = out + Chr(128 Or (c And 63))

Else

out = out + Chr(192 Or ((c \ 64) And 31))

out = out + Chr(128 Or (c And 63))

End If

Next

utf16to8 = out

End Function

Function utf8to16(str As String) As String

Dim out, i, len1, c

Dim char2, char3

out = ""

len1 = Len(str)

i = 0

While (i < len1)

c = Asc(Mid(str, i + 1, 1))

i = i + 1

Select Case (c \ 16)

Case 0 To 7

out = out + Mid(str, i, 1)

Case 12, 13

char2 = Asc(Mid(str, i + 1, 1))

i = i + 1

out = out + Chr(((c And 31) * 64) Or (char2 And 31))

Case 14

char2 = Asc(Mid(str, i + 1, 1))

i = i + 1

char3 = Asc(Mid(str, i + 1, 1))

i = i + 1

out = out + Chr(((c And 15) * 4096) Or ((char2 And 63) * 64) Or ((char3 And 63)))

End Select

Wend

utf8to16 = out

End Function

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有