用VB接收邮件（不用MAPI）？谢谢！

Question

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
''On Error GoTo Err:
'邮件接收
  Dim strData As String
  Static intMessages          As Long  '这种声明方式，返到函数体外，值不改变；
  Static intCurrentMessage    As Long
  Static strBuffer            As String
  m_StopTime = 0 '无响应时间归零
  Winsock1.GetData strData
  If Left$(strData, 1) = "+" Or mR_State = POP3_RETR Then
    Select Case mR_State
      Case POP3_Connect
          intMessages = 0
          mR_State = POP3_USER
          Winsock1.SendData "USER " & Left$(m_Email.MailName, InStr(1, m_Email.MailName, "@") - 1) & vbCrLf
      Case POP3_USER
          mR_State = POP3_PASS
          Winsock1.SendData "PASS " & m_Email.MailPass & vbCrLf
      Case POP3_PASS
          mR_State = POP3_STAT
          Winsock1.SendData "STAT" & vbCrLf
      Case POP3_STAT
          intMessages = CInt(Mid$(strData, 5, InStr(5, strData, " ") - 5))
          If intMessages > 0 Then '大于一封的邮件
              mR_State = POP3_RETR
              intCurrentMessage = intCurrentMessage + 1
              Winsock1.SendData "RETR 1" & vbCrLf
          Else '没有邮件
              mR_State = POP3_QUIT
              Winsock1.SendData "QUIT" & vbCrLf
          End If
      Case POP3_RETR
          m_StopTime = 0 '无响应时间归零
          strBuffer = strBuffer & strData
          If InStr(1, strBuffer, vbLf & "." & vbCrLf) Then
              strBuffer = Mid$(strBuffer, InStr(1, strBuffer, vbCrLf) + 2)
              strBuffer = Left$(strBuffer, Len(strBuffer) - 3)
              Set m_oMessage = New CMessage
              m_oMessage.CreateFromText strBuffer
              m_colMessages.Add m_oMessage, m_oMessage.MessageID
              Set m_oMessage = Nothing
              strBuffer = ""
              If intCurrentMessage = intMessages Then '接收完毕啦
                  mR_State = POP3_QUIT
                  Winsock1.SendData "QUIT" & vbCrLf
              Else '接收下一封
                  intCurrentMessage = intCurrentMessage + 1
                  mR_State = POP3_RETR
                  Winsock1.SendData "RETR " & CStr(intCurrentMessage) & vbCrLf
              End If
          End If
      Case POP3_QUIT
          If Winsock1.State <> 0 Then Winsock1.Close
          If intMessages > 0 Then SaveCurEMail '保存到数据库
          SendEmailOver
    End Select
  Else
    If Winsock1.State <> 0 Then Winsock1.Close
    SendEmailOver
  End If
Exit Sub
Err:
If Winsock1.State <> 0 Then Winsock1.Close
SendEmailOver
End Sub
Private Sub SaveCurEMail()
'保存当前的邮件信息
Dim oMes As CMessage
Dim oAttachment As CAttachment
Dim Conn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim sFolder As String
Dim II As Long
'------------------------------------
Dim strFileName As String
Dim strMessage As String
Dim strAttachment As String
Dim lngPosA As Long
Dim lngPosB As LongFor Each oMes In m_colMessages '循环所有的邮件
'保存到数据库
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Password=dir941421;User ID=kiss;Data Source=" & App.Path & "\OAData\OAData.mdb;Persist Security Info=True;Jet OLEDB:System database=" & App.Path & "\OAData\Secured.mdw"
'检测是否有要发送的信件
Rst.CursorLocation = adUseClient
Rst.Open "Select * From ztblMailBox", Conn, adOpenDynamic, adLockOptimistic, adCmdText
Rst.AddNew
Rst!id = MaxId(Conn, "ztblMailBox")
Rst!UserCode = m_Email.UserCode '用户信息
Rst!BoxNum = 1 '收件箱
Rst!ToFrom = oMes.From '发件人
Rst!State = False '邮件状态
Rst!Topic = oMes.Subject  '邮件主体
Rst!Content = oMes.MessageBody  '邮件内容
Rst!Accessory = strRanFolder("OAPic\EMail") '邮件附件目录
sFolder = Rst!Accessory '保存附件的存储目录
Rst!Date = Format(Mid(oMes.SendDate, InStr(1, oMes.SendDate, ",") + 1, InStr(1, oMes.SendDate, "+") - InStr(1, oMes.SendDate, ",") - 1), "yyyy-mm-dd hh:mm") '邮件日期
Rst.Update
'保存附件
  strMessage = m_colMessages(oMes.MessageID).MessageText
  For Each oAttachment In m_colMessages(oMes.MessageID).Attachments '循环当前的邮件的附件
    '文件名称处理
    strFileName = oAttachment.FileName '提出当前附件的文件名称
    lngPosA = InStr(1, strMessage, " " & strFileName)
    If lngPosA > 0 Then '文件长度大于0
      lngPosB = InStrRev(strMessage, vbCrLf, lngPosA) + 2
      If lngPosB > 2 Then
        If (Mid$(strMessage, lngPosB, lngPosA - lngPosB + Len(strFileName) + 1)) Like _
          ("begin ### " & strFileName) Then
           lngPosA = InStr(lngPosA, strMessage, "`" & vbCrLf & "end" & vbCrLf)
           If lngPosA > 0 Then
              strAttachment = Mid$(strMessage, lngPosB, lngPosA + 8 - lngPosB)
              '保存文件
              Do Until Not FolderManager.FileExists(sFolder & "\" & strFileName)
                strFileName = strFileName & CStr(II)
                II = II + 1
              Loop
              UUDecodeToFile strAttachment, sFolder & "\" & strFileName
          End If
        End If
      End If
    End If
  Next
Next
End Sub
还有两个其他的编码模块；最好不要用这个，编码太单一；用外部控件吧，建议用Jmail.dll

Answer 1

Public Function UUDecodeToFile(strUUCodeData As String, strFilePath As String)    Dim vDataLine   As Variant
    Dim vDataLines  As Variant
    Dim strDataLine As String
    Dim intSymbols  As Integer
    Dim intFile     As Integer
    Dim strTemp     As String
    If Left$(strUUCodeData, 6) = "begin " Then
        strUUCodeData = Mid$(strUUCodeData, InStr(1, strUUCodeData, vbLf) + 1)
    End If
    If Right$(strUUCodeData, 5) = "end" + vbCrLf Then
        strUUCodeData = Left$(strUUCodeData, Len(strUUCodeData) - 10)
    End If
    intFile = FreeFile
    Open strFilePath For Binary As intFile
        vDataLines = Split(strUUCodeData, vbCrLf)
        For Each vDataLine In vDataLines
                strDataLine = CStr(vDataLine)
                intSymbols = Asc(Left$(strDataLine, 1)) - 32
                strDataLine = Mid$(strDataLine, 2)
                strDataLine = Replace(strDataLine, "`", " ")
                For i = 1 To Len(strDataLine) Step 4
                    '1 byte
                    strTemp = strTemp + Chr((Asc(Mid(strDataLine, i, 1)) - 32) * 4 + _
                              (Asc(Mid(strDataLine, i + 1, 1)) - 32) \ 16)
                    '2 byte
                    strTemp = strTemp + Chr((Asc(Mid(strDataLine, i + 1, 1)) Mod 16) * 16 + _
                              (Asc(Mid(strDataLine, i + 2, 1)) - 32) \ 4)
                    '3 byte
                    strTemp = strTemp + Chr((Asc(Mid(strDataLine, i + 2, 1)) Mod 4) * 64 + _
                              Asc(Mid(strDataLine, i + 3, 1)) - 32)
                Next i
                strTemp = Left(strTemp, intSymbols)
                'write decoded line to the file
                Put intFile, , strTemp
                'clear buffer for next line
                strTemp = ""
        Next
    Close intFile
End Function
Public Function UUDecodeToFile(strUUCodeData As String, strFilePath As String)    Dim vDataLine   As Variant
    Dim vDataLines  As Variant
    Dim strDataLine As String
    Dim intSymbols  As Integer
    Dim intFile     As Integer
    Dim strTemp     As String
    If Left$(strUUCodeData, 6) = "begin " Then
        strUUCodeData = Mid$(strUUCodeData, InStr(1, strUUCodeData, vbLf) + 1)
    End If
    If Right$(strUUCodeData, 5) = "end" + vbCrLf Then
        strUUCodeData = Left$(strUUCodeData, Len(strUUCodeData) - 10)
    End If
    intFile = FreeFile
    Open strFilePath For Binary As intFile
        vDataLines = Split(strUUCodeData, vbCrLf)
        For Each vDataLine In vDataLines
                strDataLine = CStr(vDataLine)
                intSymbols = Asc(Left$(strDataLine, 1)) - 32
                strDataLine = Mid$(strDataLine, 2)
                strDataLine = Replace(strDataLine, "`", " ")
                For i = 1 To Len(strDataLine) Step 4
                    '1 byte
                    strTemp = strTemp + Chr((Asc(Mid(strDataLine, i, 1)) - 32) * 4 + _
                              (Asc(Mid(strDataLine, i + 1, 1)) - 32) \ 16)
                    '2 byte
                    strTemp = strTemp + Chr((Asc(Mid(strDataLine, i + 1, 1)) Mod 16) * 16 + _
                              (Asc(Mid(strDataLine, i + 2, 1)) - 32) \ 4)
                    '3 byte
                    strTemp = strTemp + Chr((Asc(Mid(strDataLine, i + 2, 1)) Mod 4) * 64 + _
                              Asc(Mid(strDataLine, i + 3, 1)) - 32)
                Next i
                strTemp = Left(strTemp, intSymbols)
                'write decoded line to the file
                Put intFile, , strTemp
                'clear buffer for next line
                strTemp = ""
        Next
    Close intFile
End Function
用这种方式，发送还勉强可以，接受的时候编码不规范的，所以强烈建议使用其他的外部控件；简单方便；
发送的时候，用VB编码，速度慢的惊人，怎么优化都没有用的；VB字符串处理就是慢的；

Answer 2

Jmail.dll？可以用这个写一个例子吗？
谢谢！

Answer 3

http://www.csdn.net/expert/topic/736/736659.xml?temp=8.074588E-02有我的一个Jmail.dll的例子