メール受信

  model.inc



メールデータ受信用として、前もってプログラムディレクトリに MailData と MailTemp を作成します

  
<%
' **********************************************************
' 件数取得
' **********************************************************
Function GetMailCount( )

	Dim Basp,Result,aWork

	Set Basp = Server.CreateObject( "Basp21" )

	Result = Basp.RcvMail( _
		POP3Server, _
		UserName, _
		UserPassword, _
		"STAT" , _
		">" & Server.MapPath( "MailData" ) _
	)

	if IsArray( Result ) then
		aWork = Split( Result( 0 ), " " )
		Message = "メールは " & aWork( 0 ) & " 件受信可能です"
	else
		ErrMessage = "メール処理のエラーです : "
		ErrMessage = ErrMessage & Result
	end if

	Set Basp = Nothing

End Function

' **********************************************************
' ヘッダー情報の一覧
' **********************************************************
Function GetMailList( )

	Dim Basp,Result

	Set Basp = Server.CreateObject( "Basp21" )

	Result = Basp.RcvMail( _
		POP3Server, _
		UserName, _
		UserPassword, _
		"LIST" , _
		">" & Server.MapPath( "MailData" ) _
	)

	Set Basp = Nothing

	if IsArray( Result ) then
		For I = 0 to Ubound( Result )
			Call EditMailData( Result( i ) )
		Next
	else
		ErrMessage = "メール処理のエラーです : "
		ErrMessage = ErrMessage & Result
	end if

End Function

' **********************************************************
' ヘッダー情報の一覧の編集
' **********************************************************
Function EditMailData( RowData )

	Dim aMail

	aMail = Split( RowData, vbTab )

	OutData = OutData & "<TR>"

	OutData = OutData & "<TD class=MyCell>"
	strWork = Replace( aMail( 1 ), "From: ", "" )
	strWork = Server.HTMLEncode( strWork )
	OutData = OutData & strWork
	OutData = OutData & "</TD>"

	OutData = OutData & "<TD class=MyCell>"
	OutData = OutData &  Replace( aMail( 0 ), "Subject: ", "" )
	OutData = OutData & "</TD>"

	OutData = OutData & "<TD class=MyCell>"
	OutData = OutData &  Replace( aMail( 2 ), "Date: ", "" )
	OutData = OutData & "</TD>"

	OutData = OutData & "</TR>"

End Function

' **********************************************************
' メールデータの受信と一覧
' **********************************************************
Function GetMailList2( )

	Dim Basp,Result,I

	Set Basp = Server.CreateObject( "Basp21" )

	Result = Basp.RcvMail( _
		POP3Server, _
		UserName, _
		UserPassword, _
		"SAVE 1-10" , _
		">" & Server.MapPath( "MailData" ) _
	)

	if IsArray( Result ) then
		For I = 0 to Ubound( Result )
			Call EditMailData2( Basp, Result( i ) )
		Next
	else
		ErrMessage = "メール処理のエラーです : "
		ErrMessage = ErrMessage & Result
	end if

	Set Basp = Nothing

End Function

' **********************************************************
' メールデータの受信と一覧の編集
' **********************************************************
Function EditMailData2( Basp, RowFile )

	Dim Result,I

	Result = Basp.ReadMail( _
		RowFile, _
		"", _
		Server.MapPath( "MailTemp" ) _
	)

	if not IsArray( Result ) then
		OutData = OutData & "<TR>"
		OutData = OutData & "<TD class=MyCell colspan=3>"
		OutData = OutData &  "読込エラー : " & Result
		OutData = OutData & "</TD>"
		OutData = OutData & "</TR>"
		Exit Function
	end if

	OutData = OutData & "<TR>"
	For I = 0 to Ubound( Result )
	   if Left( Result(I), 5 ) = "From:" then
	      OutData = OutData & "<TD class=MyCell>"
	      OutData = OutData & "<A href=""control.asp?In2Command=ReadMail&target="
	      OutData = OutData & Server.UrlEncode(RowFile)
	      OutData = OutData & "&GNO=" & PASS_LIST & """>"
	      strWork = Replace( Result(I), "From: ", "" )
	      strWork = Server.HTMLEncode( strWork )
	      OutData = OutData & strWork
	      OutData = OutData & "</A>"
	      OutData = OutData & "</TD>"
	   end if
	Next
	For I = 0 to Ubound( Result )
		if Left( Result(I), 8 ) = "Subject:" then
			OutData = OutData & "<TD class=MyCell>"
			OutData = OutData &  Replace( Result(I), "Subject: ", "" )
			OutData = OutData & "</TD>"
		end if
	Next
	For I = 0 to Ubound( Result )
		if Left( Result(I), 5 ) = "Date:" then
			OutData = OutData & "<TD class=MyCell>"
			OutData = OutData &  Replace( Result(I), "Date: ", "" )
			OutData = OutData & "</TD>"
		end if
	Next
	OutData = OutData & "</TR>"

End Function

' **********************************************************
' メール本文の表示
' **********************************************************
Function ReadMail( )

	Dim Basp,Result,I,strWork

	Set Basp = Server.CreateObject( "Basp21" )

	Result = Basp.ReadMail( _
		MyData( "target" ), _
		"", _
		Server.MapPath( "MailTemp" ) _
	)

	if not IsArray( Result ) then
		OutData = OutData & "<TR>"
		OutData = OutData & "<TD class=MyCell colspan=3>"
		OutData = OutData &  "読込エラー : " & Result
		OutData = OutData & "</TD>"
		OutData = OutData & "</TR>"
		Exit Function
	end if

	OutData = OutData & "<TR>"
	For I = 0 to Ubound( Result )
		if Left( Result(I), 5 ) = "From:" then
			OutData = OutData & "<TD class=MyCell><B>"
			strWork = Replace( Result(I), "From: ", "" )
			strWork = Server.HTMLEncode( strWork )
			OutData = OutData & strWork
		end if
	Next
	For I = 0 to Ubound( Result )
		if Left( Result(I), 12 ) = "Return-Path:" then
			OutData = OutData &  "</B><BR>"
			OutData = OutData &  Replace( Result(I), "Return-Path: ", "" )
			OutData = OutData & "</B></TD>"
		end if
	Next
	For I = 0 to Ubound( Result )
		if Left( Result(I), 8 ) = "Subject:" then
			OutData = OutData & "<TD class=MyCell><B>"
			OutData = OutData &  Replace( Result(I), "Subject: ", "" )
			OutData = OutData & "</B></TD>"
		end if
	Next
	For I = 0 to Ubound( Result )
		if Left( Result(I), 5 ) = "Date:" then
			OutData = OutData & "<TD class=MyCell>"
			OutData = OutData &  Replace( Result(I), "Date: ", "" )
			OutData = OutData & "</TD>"
		end if
	Next
	For I = 0 to Ubound( Result )
		if Left( Result(I), 5 ) = "Body:" then
			OutData = OutData & "</TR>"
			OutData = OutData & "<TR>"
			OutData = OutData & "<TD class=MyCell colspan=3>"
			strWork = Replace( Result(I), "Body: ", "" )
			strWork = Server.HTMLEncode( strWork )
			strWork = Replace( strWork, vbCrLf, "<BR>" )
			OutData = OutData &  strWork
			OutData = OutData & "</TR>"
		end if
	Next

	Set Basp = Nothing

End Function

' **********************************************************
' VIEW の編集
' **********************************************************
Function EditDataHead( )


End Function

' **********************************************************
' VIEW2 の編集
' **********************************************************
Function EditDataBody( )


End Function

%>
  














   SQLの窓    create:2004/11/02  update:2015/09/23   管理者用(要ログイン)





フリーフォントツール

SQLの窓ツール

SQLの窓フリーソフト

写真素材

一般ツールリンク

SQLの窓

フリーソフト