BASP21 (メール送受信)


  BMail.bas




  

Global BMail
Global BMail_SmtpServer
Global BMail_MailFrom
Global BMail_PopServer
Global BMail_User
Global BMail_Password
Global BMail_RcvDir
Global BMail_LastError
Global BMail_MailSize
Global BMail_MailCount
Global BMail_MailFile

' ******************************************************
' 初期化
' ******************************************************
Public Function lbInitBMail()

    If Not IsObject(BMail) Then
        Set BMail = CreateObject("Basp21")
    End If

End Function

' ******************************************************
' 受信処理の初期化
' ******************************************************
Public Function lbInitRcv(PopServer, User, Password, RcvDir)

    BMail_PopServer = PopServer
    BMail_User = User
    BMail_Password = Password
    BMail_RcvDir = RcvDir
    If Not FsExist(RcvDir & "", 1) Then
        Call FsMkDir(RcvDir & "")
    End If

End Function

' ******************************************************
' ユーザ・パスワードの初期化
' ******************************************************
Public Function lbInitUserPass(User, Password)

    BMail_User = User
    BMail_Password = Password

End Function

' ******************************************************
' 送信処理の初期化
' ******************************************************
Public Function lbInitSnd(SmtpServer)

    BMail_SmtpServer = SmtpServer

End Function

' ******************************************************
' メール件数の取得
' ******************************************************
Public Function lbGetMailCount() As Long

    Dim Output
    Dim strArray

    ' 初期化
    Call lbInitBMail
    
    ' 受信
    Output = BMail.RcvMail( _
                BMail_PopServer, _
                BMail_User, _
                BMail_Password, _
                "STAT", ">" & BMail_RcvDir _
                )

    ' 正常終了
    If IsArray(Output) Then
        strArray = Split(Output(0), " ")
        If IsArray(strArray) Then
            BMail_MailSize = Val(strArray(1))
            BMail_MailCount = Val(strArray(0))
        Else
            BMail_MailSize = 0
            BMail_MailCount = 0
        End If
    ' 異常終了
    Else
        BMail_MailCount = -1
        BMail_LastError = Output
    End If
    
    lbGetMailCount = BMail_MailCount

End Function

' ******************************************************
' メールタイトルの取得
' ******************************************************
Public Function lbGetMailList()

    Dim Output

    ' 初期化
    Call lbInitBMail
    
    ' 受信
    Output = BMail.RcvMail( _
                BMail_PopServer, _
                BMail_User, _
                BMail_Password, _
                "LIST", ">" & BMail_RcvDir _
                )

    If IsArray(Output) Then
        BMail_MailCount = UBound(Output) + 1
    Else
        BMail_MailCount = 0
    End If

    lbGetMailList = Output

End Function

' ******************************************************
' メールタイトルをグリッドへセット
' ******************************************************
Public Function lbGetMailListToGrid(Grid As MSHFlexGrid)

    Dim Output
    Dim PosFrom
    Dim PosDate
    Dim idx

    ' 初期化
    Call lbInitBMail
        
    Grid.Cols = 4
    
    ' 受信
    Output = BMail.RcvMail( _
                BMail_PopServer, _
                BMail_User, _
                BMail_Password, _
                "LIST", ">" & BMail_RcvDir _
                )

    If IsArray(Output) Then
        BMail_MailCount = UBound(Output) + 1
        Grid.Rows = 2
        Grid.TextMatrix(1, 1) = ""
        For idx = 1 To BMail_MailCount
            Grid.Rows = idx + 1
            PosFrom = InStrRev(Output(idx - 1), "From:")
            PosDate = InStrRev(Output(idx - 1), "Date:")
            Grid.TextMatrix(idx, 0) = idx
            Grid.TextMatrix(idx, 1) = _
                Mid(Output(idx - 1), 10, PosFrom - 10)
            Grid.TextMatrix(idx, 2) = _
                Mid(Output(idx - 1), PosFrom + 6, PosDate - PosFrom - 6)
            Grid.TextMatrix(idx, 3) = _
                Mid(Output(idx - 1), PosDate + 6, Len(Output(idx - 1)) - PosDate - 5)
        Next
    Else
        BMail_MailCount = 0
        Grid.Rows = 1
    End If

    lbGetMailListToGrid = Output

End Function

' ******************************************************
' メールの送信
' ******************************************************
Public Function lbSendMail(Mailto, Mailfrom, Subject, Body)

    ' 初期化
    Call lbInitBMail
    
    If Mailfrom = "" Then
        lbSendMail = BMail.SendMail( _
                BMail_SmtpServer, _
                Mailto, _
                BMail_MailFrom, _
                Subject, Body, "" _
            )
    Else
        lbSendMail = BMail.SendMail( _
                BMail_SmtpServer, _
                Mailto, _
                Mailfrom, _
                Subject, _
                Body, "" _
            )
    End If

End Function

' ******************************************************
' 番号より、本文のみを取得する
' 【戻り値】: 本文
' ******************************************************
Public Function lbRcvMail(MailNo)

    Dim Output
    Dim OutArray

    ' 初期化
    Call lbInitBMail
    
    ' 受信
    BMail_MailFile = ""
    Output = BMail.RcvMail( _
                BMail_PopServer, _
                BMail_User, _
                BMail_Password, _
                "SAVE " & MailNo, ">" & BMail_RcvDir _
                )


    If IsArray(Output) Then
        BMail_MailFile = Output(0)
        OutArray = BMail.ReadMail(Output(0), "body:nofile:", ">" & BMail_RcvDir)
        If IsArray(OutArray) Then
            lbRcvMail = Mid(OutArray(0), 7, Len(OutArray(0)) - 6)
        Else
            lbRcvMail = ""
        End If
    Else
        lbRcvMail = ""
    End If

End Function

' ******************************************************
' 番号より、メールをサーバから削除
' ******************************************************
Public Function lbDelMail(MailNo)
    
    Dim Output
    Dim OutArray

    ' 初期化
    Call lbInitBMail
    
    ' 受信
    BMail_MailFile = ""
    Output = BMail.RcvMail( _
                BMail_PopServer, _
                BMail_User, _
                BMail_Password, _
                "DELE " & MailNo, ">" & BMail_RcvDir _
                )

    If Val(Output) = 1 Then
        lbDelMail = True
    Else
        lbDelMail = False
    End If

End Function

  







  実行サンプル




  

' ******************************************************
' 初期化
' ******************************************************
Private Sub Form_Load()

    Call lbInitSnd("xxx.xxx.xxx.xxx")
    Call lbInitRcv("xxx.xxx.xxx.xxx", "xxxxxx", "xxxxxx", "C:\temp\rcvdir")
    BMail_MailFrom = "lightbox@nifty.com"
    
    Grid.AllowUserResizing = flexResizeColumns
    Grid.ScrollTrack = True

End Sub

' ******************************************************
' Subject、From、Dateヘッダーの一覧
' ******************************************************
Private Sub 一覧取得_Click()

    Call lbGetMailListToGrid(Grid)

End Sub

' ******************************************************
' メールを送る
' ******************************************************
Private Sub 送信_Click()

    Call MsgBox(lbSendMail("xxxxxx@xxxxxx", "", Now, 本文.Text))

End Sub

' ******************************************************
' サーバから削除
' ******************************************************
Private Sub 削除_Click()

    Call lbDelMail(番号.Text)

End Sub

' ******************************************************
' 本文表示
' ******************************************************
Private Sub Grid_DblClick()

    MsgBox lbRcvMail(Grid.Row)
    MsgBox BMail_MailFile

End Sub


  




yahoo  google  MSDN  MSDN(us)  WinFAQ  Win Howto  tohoho  ie_DHTML  vector  wdic  辞書  天気 


[PROvbFunction]
CCBot/2.0 (https://commoncrawl.org/faq/)
19/08/21 22:22:35
InfoBoard Version 1.00 : Language=Perl

BatchHelper COMprog CommonSpec Cprog CprogBase CprogSAMPLE CprogSTD CprogSTD2 CprogWinsock Cygwin GameScript HTML HTMLcss InstallShield InstallShieldFunc JScript JScriptSAMPLE Jsfuncs LLINK OldProg OracleGold OracleSilver PRO PRObrowser PROc PROconePOINT PROcontrol PROftpclient PROjscript PROmailer PROperl PROperlCHAT PROphp PROphpLesson PROphpLesson2 PROphpLesson3 PROphpfunction PROphpfunctionArray PROphpfunctionMisc PROphpfunctionString PROsql PROvb PROvbFunction PROvbString PROvbdbmtn PROvbonepoint PROwebapp PROwin1POINT PROwinSYSTEM PROwinYOROZU PROwindows ProjectBoard RealPHP ScriptAPP ScriptMaster VBRealtime Vsfuncs a1root access accreq adsi ajax amazon argus asp aspSample aspVarious aspdotnet aw2kinst cappvariety centura ckeyword classStyle cmaterial cmbin cmdbapp cmenum cmlang cmlistbox cmstd cmstdseed cmtxt cs daz3d db dbCommon dbaccess dnettool dos download flex2 flex3 flex4 framemtn framereq freeWorld freesoft gimp ginpro giodownload google hdml home hta htmlDom ie9svg install java javaSwing javascript jetsql jquery jsp jspTest jspVarious lightbox listasp listmsapi listmsie listmsiis listmsnt listmspatch listmsscript listmsvb listmsvc memo ms msde mysql netbeans oraPlsql oracle oracleWiper oraclehelper orafunc other panoramio pear perl personal pgdojo pgdojo_cal pgdojo_holiday pgdojo_idx pgdojo_ref pgdojo_req php phpVarious phpguide plsql postgres ps r205 realC realwebapp regex rgaki ruby rule sboard sc scprint scquest sdb sdbquest seesaa setup sh_Imagick sh_canvas sh_dotnet sh_google sh_tool sh_web shadowbox shgm shjquery shvbs shweb sjscript skadai skywalker smalltech sperl sqlq src systemdoc tcpip tegaki three toolbox twitter typeface usb useXML vb vbdb vbsfunc vbsguide vbsrc vpc wcsignup webanymind webappgen webclass webparts webtool webwsh win8 winofsql wmi work wp youtube