インターネットを利用したWindows DNAシステムの考案

DATE = 100/7/3 17:24:19
AGENT = Mozilla/4.0 (compatible; MSIE 5.0; Windows 98; DigExt)
----------------------------------------------------
txtName = しんじ
optSex = 1
cboArea = 関東
cboAge1 = 1
cboAge2 = 4
txtEmail = shinji@nerv.go.jp
chkArea01 = 北海道
chkArea02 = 東北
chkArea03 = 関東
chkArea04 = 中部
chkArea05 = 近畿
chkArea06 = 中国
chkArea07 = 四国
chkArea08 = 九州
cboAgeL1 = 1
cboAgeL2 = 0
cboAgeH1 = 9
cboAgeH2 = 9
----------------------------------------------------

' POPサーバーにログイン
popMailGW.Login pstrGetIni(App.EXEName, "POP3", mstrIniFile), _ ---+
                pstrGetIni(App.EXEName, "USER", mstrIniFile), _    +-《1》
                pstrGetIni(App.EXEName, "PASS", mstrIniFile)    ---+
lngCnt = popMailGW.Count   ------------------------------------------《2》
' メール処理
    If lngCnt > 0 Then
      Call subLogSet(lngCnt & "通のメールがあります。")
      For ilngLoop = 1 To lngCnt
      ' ヘッダ部分を受信して、送信元を判定
        popMailGW.Get msgPreview, CStr(ilngLoop)  -------------------《3》
        strSender = _
         StrConv(popMailGW.Messages(ilngLoop).From, vbLowerCase) ----《4》
        If strFrom = strSender Then
        ' 規定の送信元からなのでメール本文を処理
          popMailGW.Get msgContent, CStr(ilngLoop) ------------------《5》
          Set msgMail = popMailGW.Messages(ilngLoop) ----------------《6》
                             :
                           (中略)
                             :
                        popMailGW.Delete CStr(ilngLoop) -------------《7》
                             :
                           (中略)
                             :
    End If
    popMailGW.Logout ------------------------------------------------《8》

Private Function strURLDecode( _
 ByVal rstrPost As String) As String
  Dim intindex  As Integer
  Dim intPos    As Integer
  Dim strAsc    As String
    
' 8bit Decode
  intindex = 1
  strURLDecode = ""
  intPos = InStr(rstrPost, "%")
  Do While intPos > 0
    If intPos > 1 Then
      strURLDecode = strURLDecode & _
       Mid$(rstrPost, intindex, intPos - 1)
      intindex = intindex + intPos
    Else
      intindex = intindex + 1
    End If
    strAsc = StrConv( _
      Mid$(rstrPost, intindex, 2), vbUpperCase)
    intindex = intindex + 2
    If strAsc > "7F" Then
    ' 漢字項目なので
      If Mid$(rstrPost, intindex, 1) = "%" Then
        strAsc = Chr(CInt("&H" & strAsc & _
                  Mid$(rstrPost, intindex + 1, 2)))
        intindex = intindex + 3
      Else
        strAsc = Chr$(CInt("&H" & strAsc & _
                  Hex(Asc(Mid$(rstrPost, intindex, 1)))))
        intindex = intindex + 1
      End If
    Else
      strAsc = Chr$(CInt("&H" & strAsc))
    End If
      strURLDecode = strURLDecode & strAsc
      intPos = InStr( _
       Mid$(rstrPost, intindex), "%")
  Loop
  strURLDecode = strURLDecode & _
                 Mid$(rstrPost, intindex)
' + Decode
  strAsc = strURLDecode
#If VB6 Then
  strURLDecode = _
   Replace(strAsc, "+", " ", 1, -1, vbTextCompare)
#Else
  intPos = InStr(strAsc, "+")
  Do While intPos > 0
    Mid$(strAsc, intPos, 1) = " "
    intPos = InStr(strAsc, "+")
  Loop
  strURLDecode = strAsc
#End If
End Function

Private Function blnMailStore( _
 ByRef rastrItem() As String) As Boolean
' メールをDBに格納する
  Dim blnRet    As Boolean   ' 処理結果
  Dim rdynLocal As Recordset ' レコード
  Dim strSQL    As String    ' SQL文
  Dim strItem   As String    ' 項目値
  Dim lngCID    As Long      ' 処理対象ID
  On Error GoTo errMailStore:
        
  blnRet = False
    
  strItem = StrConv(rastrItem(6), _
   vbLowerCase + vbNarrow)
  strSQL = "SELECT * FROM 登録データ " & _
               "WHERE email='" & strItem & "'"
  Set rdynLocal = _
   pdbsLocal.OpenRecordset(strSQL, dbOpenDynaset)
  If rdynLocal.EOF Then
  ' 新規登録
    rdynLocal.AddNew
    rdynLocal("姓名").Value = Trim$(rastrItem(1))
    rdynLocal("性別").Value = rastrItem(2)
    rdynLocal("居住地域").Value = rastrItem(3)
    rdynLocal("年齢").Value = _
             CInt(rastrItem(4) & rastrItem(5))
    rdynLocal("email").Value = strItem
    rdynLocal("希望地域１").Value = rastrItem(8)
    rdynLocal("希望地域２").Value = rastrItem(9)
    rdynLocal("希望地域３").Value = rastrItem(10)
    rdynLocal("希望地域４").Value = rastrItem(11)
    rdynLocal("希望地域５").Value = rastrItem(12)
    rdynLocal("希望地域６").Value = rastrItem(13)
    rdynLocal("希望地域７").Value = rastrItem(14)
    rdynLocal("希望地域８").Value = rastrItem(15)
    rdynLocal("希望年齢下限").Value = _
             CInt(rastrItem(16) & rastrItem(17))
    rdynLocal("希望年齢上限").Value = _
             CInt(rastrItem(18) & rastrItem(19))
    rdynLocal("登録済フラグ").Value = False
    rdynLocal.Update
    rdynLocal.Close
    strSQL = "SELECT * FROM 登録データ " & _
             "WHERE email='" & strItem & "'"
    Set rdynLocal = _
     pdbsLocal.OpenRecordset(strSQL, dbOpenDynaset)
    If Not rdynLocal.EOF Then
      lngCID = rdynLocal("ID").Value
      blnRet = blnMailSend(mcintEntry, strItem, lngCID)
    End If
      rdynLocal.Close
  Else
  ' 個人情報の更新(今回は未サポート)
    blnRet = True
  End If
exitMailStore:
  On Error Resume Next
  rdynLocal.Close
  blnMailStore = blnRet
  Exit Function
    
errMailStore:
  Call subLogSet("frmMailGW/blnMailStore:" & Error$)
  blnRet = False
  Resume exitMailStore:
  Resume Next
End Function

Private Function blnMailSend( _
 ByVal vintType As Integer, _
 ByVal vstrTo As String, _
 ByVal vlngCID As Long, _
 Optional ByVal vstrMsg As String) As Boolean
' リプライメールを返信する
  Dim blnRet     As Boolean  ' 処理結果
  Dim strSMTP    As String   ' SMTPサーバー
  Dim strBody    As String   ' メール本文
  Dim intFno     As String   ' メッセージ
  Dim strBuf     As String   ' 読み込みバッファ
  Dim strFotter  As String   ' メールフッター
  On Error GoTo errMailSend:
    
  blnRet = False
  smtpMailGW.Login pstrGetIni( _
    App.EXEName, "SMTP", mstrIniFile) -------------------《1》
' メッセージの取得
  strBody = ""
  intFno = FreeFile
  Select Case vintType
  Case mcintEntry
    Open CurDir$ & _ -----------------------------------------+
     "\entry.txt" For Input Access Read Lock Write As #intFno +-《2》
    smtpMailGW.Message.Subject = "VBM0009 - 登録確認" --------+
                              :
                            (中略)
                              :
' メッセージの送信
  smtpMailGW.To.Clear  -----------------------------------《3》
  smtpMailGW.To.Add vstrTo -------------------------------《4》
  If pstrGetIni(App.EXEName, "SENDER", mstrIniFile) <> "" Then
    smtpMailGW.From = _
     pstrGetIni(App.EXEName, "SENDER", mstrIniFile)
  Else
    smtpMailGW.From = _
     pstrGetIni(App.EXEName, "FROM", mstrIniFile) --------《5》
  End If
  smtpMailGW.Message.Text = strBody  ---------------------《6》
  smtpMailGW.Send  ---------------------------------------《7》
  Call subLogSet(vbTab & "-->" & vstrTo)
  blnRet = True
exitMailSend:
  Close #intFno
  smtpMailGW.Logout  -------------------------------------《8》
  blnMailSend = blnRet
  Exit Function
    
errMailSend:
  Call subLogSet("frmMailGW/blnMailSend:" & Error$)
  Resume exitMailSend:
  Resume Next
End Function

入会申込を受領しました。
いたずら防止のために、下記のurl にアクセスして、登録
完了を行なってください。
もし、本メールが身に覚えのないものでしたら、破棄して
頂ければ、入会した事にはなりませんので、ご安心くださ
い。
http://www.ask.ne.jp/~pratze/vbm0009/reg.cgi?ID=1111

#!/usr/local/bin/perl
require './jcode.pl';
@pairs = split(/&/,$ENV{'QUERY_STRING'});
foreach $pair (@pairs) {
	($name, $value) = split(/=/, $pair);
	$value =~ tr/+/ /;
	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	$value =~ s/\n//g;
	$value =~ s/\,//g;
	&jcode'convert(*value,'sjis');
	$FORM{$name} = $value;
}
#確認ページを生成
print "Content-type: text/html\n\n";
print "<html><head><title>Visual Basic Magazine 2000/09 Sample Web Page</title></head>\n";
print "<body>\n";
print "<img src=\"./vbm_logo.gif\">\n";
print "<center><h1>Visual Basic Magazine 2000年9月号特集のサンプル</h1></center>\n";
print "<center><h3>登録確認</h3></center>\n";
print "<!--フォームの送信ボタンが押されるとformmail.cgiを実行-->\n";
print "<form action=\"./formmail.cgi\" method=\"POST\">\n";
print "<input type=hidden name=subject VALUE=\"VBM0009 - REGIST\">\n";
print "<table border=0>\n";
print "<tr>\n";
print "<td align=right>ID</td>\n";
print "<td><input type=text size=31 name=CID value=\"$FORM{'ID'}\"></td>\n";
print "</tr>\n";
print "<tr>\n";
print "<td align=right>メールアドレス</td>\n";
print "<td><input type=text size=31 name=txtEmail></td>\n";
print "</tr>\n";
print "<tr>\n";
print "<td align=right></td>\n";
print "<td>\n";
print "<SELECT id=cboYearLow1 name=cboReg>\n";
print "	<OPTION selected value=\"登録\">登録</OPTION> <OPTIONSELECTED>\n";
print "	<OPTION value=\"退会\">退会</OPTION> <OPTIONSELECTED>\n";
print "</SELECT>\n";
print "IDとメールアドレスで本人かどうかを認証しています。</td>\n";
print "</td>\n";
print "</tr>\n";
print "</table>\n";
print "<!--送信ボタンのnameプロパティーは設定しない-->\n";
print "<p><input type=submit value='送信'>\n";
print "<input type=reset value='リセット'></p>\n";
print "</form>\n";
print "<hr width=80%>\n";
print "本サンプルは、2000年9月1日までの限定公開サンプルです。<br>\n";
print "</body>\n";
print "</html>\n";
exit;

Option Explicit
Declare Function GetStdHandle Lib "kernel32" _
                (ByVal nStdHandle As Long) As Long
Declare Function WriteFile Lib "kernel32" _
                (ByVal hFile As Long, _
                 lpBuffer As Any, _
                 ByVal nNumberOfBytesToWrite As Long, _
                 lpNumberOfBytesWritten As Long, _
                 ByVal lpOverlapped As Long) As Long
Declare Function ReadFile Lib "kernel32" _
                (ByVal hFile As Long, _
                 lpBuffer As Any, _
                 ByVal nNumberOfBytesToRead As Long, _
                 lpNumberOfBytesRead As Long, _
                 lpOverlapped As Any) As Long
Public Const STD_INPUT_HANDLE As Long = -10&
Public Const STD_OUTPUT_HANDLE As Long = -11&
Public Const STD_ERROR_HANDLE As Long = -12&
Private Sub Main()
  On Error GoTo errMain:
  ' 応答コード部
  printf "HTTP/1.0 200 OK" & vbCrLf
  ' ヘッダ部
  printf "Content-type: text/html" & vbCrLf & vbCrLf
  printf "<html><head><title>Visual Basic Magazine " & _
         "2000/09 Sample Web Page</title></head>" & vbCrLf
  printf "<body>" & vbCrLf
  printf "<img src=""./vbm_logo.gif"">" & vbCrLf
  printf "<center><h1>Visual Basic Magazine" & _
         "2000年9月号特集のサンプル</h1></center>" & vbCrLf
  printf "<center><h3>登録確認</h3></center>" & vbCrLf
  printf "<!--フォームの送信ボタンが押されるとformmail.cgiを実行-->" & vbCrLf
  printf "<form action=""./formmail.cgi"" method=""POST"">" & vbCrLf
  printf "<input type=hidden name=subject VALUE=""VBM0009 - REGIST""> " & vbCrLf
  printf "<table border=0>" & vbCrLf
  printf "<tr>" & vbCrLf
  printf "<td align=right>ID</td>" & vbCrLf
  printf "<td><input type=text size=31 name=CID " & _
         "value=""" & _
         strFindKeyValue(Environ("QUERY_STRING"), _
         "ID") & """>" & _
         "</td>" & vbCrLf
  printf "</tr>" & vbCrLf
  printf "<tr>" & vbCrLf
  printf "<td align=right>メールアドレス</td>" & vbCrLf
  printf "<td><input type=text size=31 name=txtEmail></td>" & vbCrLf
  printf "</tr>" & vbCrLf
  printf "<tr>" & vbCrLf
  printf "<td align=right></td>" & vbCrLf
  printf "<td>" & vbCrLf
  printf "<SELECT id=cboYearLow1 name=cboReg>" & vbCrLf
  printf " <OPTION selected value=""登録>登録</OPTION> <OPTIONSELECTED>" & vbCrLf
  printf " <OPTION value=""退会>退会</OPTION> <OPTIONSELECTED>" & vbCrLf
  printf "</SELECT>" & vbCrLf
  printf "IDとメールアドレスで本人かどうかを認証しています。</td>" & vbCrLf
  printf "</td>" & vbCrLf
  printf "</tr>" & vbCrLf
  printf "</table>" & vbCrLf
  printf "<!--送信ボタンのnameプロパティーは設定しない-->" & vbCrLf
  printf "<p><input type=submit value='送信'>" & vbCrLf
  printf "<input type=reset value='リセット'></p>" & vbCrLf
  printf "</form>" & vbCrLf
  printf "<hr width=80%>" & vbCrLf
  printf "本サンプルは、2000年9月1日までの限定公開サンプルです。<br>" & vbCrLf
  printf "</body>" & vbCrLf
  printf "</html>" & vbCrLf
exitMain:
  On Error Resume Next
  Exit Sub
errMain:
  printf Error$
  Resume exitMain:
End Sub
Private Sub printf(ByVal strBuffer As String)
  Dim abytBuffer()  As Byte
  Dim lngOutLen     As Long
  Dim lngBytes      As Long
  Dim lngRet        As Long
  Dim hStdOut       As Long
  
  Debug.Print strBuffer;
' VBの内部コードであるUnicodeから
' SJISに変換してそれをバイナリとして扱う。
  abytBuffer = StrConv(strBuffer, vbFromUnicode)
' バイト配列の大きさ（いわゆる文字列長）を求める
  lngOutLen = UBound(abytBuffer) - LBound(abytBuffer) + 1
'標準出力ハンドルを取得する
  hStdOut = GetStdHandle(STD_OUTPUT_HANDLE)
'標準出力先へSJISコードのまま出力する。
  lngRet = WriteFile(hStdOut, _
                     abytBuffer(0), _
                     lngOutLen, _
                     lngBytes, _
                     0&)
End Sub
Private Function strFindKeyValue( _
 rstrQuery As String, rstrKey As String) As String
  Dim astrTmp()   As String
  Dim iintLoop    As Integer
  Dim intPos      As Integer
  strFindKeyValue = ""
  If rstrQuery <> "" Then
   #If VB6 Then
     astrTmp() = Split(rstrQuery, "&", -1, vbTextCompare)
     For iintLoop = 0 To UBound(astrTmp)
       intPos = InStr(astrTmp(iintLoop), rstrKey & "=")
       If intPos > 0 Then
         strFindKeyValue = Mid$(astrTmp(iintLoop), _
                           intPos + Len(rstrKey & "="))
       End If
     Next
   #Else
     If InStr(astrTmp(iintLoop), rstrKey & "=") > 1 Then
       intPos = InStr(astrTmp(iintLoop), "&" & rstrKey & "=")
       strFindKeyValue = Mid$(rstrQuery, _
                         intPos + Len("&" & rstrKey & "="))
     Else
       strFindKeyValue = Left$(rstrQuery, Len(rstrKey & "="))
     End If
   #End If
  End If
End Function

お友達をご紹介します。
--------------------
関東にお住まいのはつね様(女性)
--------------------
メッセージを送るときには
    http://www.ask.ne.jp/~pratze/vbm0009/msg.cgi?ID=132
をクリックしてメッセージを送信してください。

1. Aさんに秘密鍵と公開鍵をPGPにより作成してもらい、公開鍵のみをメール（もちろんこのときは暗号化前の平文メールだ）してもらう
2. メール送信元では、PGPにAさんの公開鍵を使ってメール本文を暗号化してからメール送信する。この暗号化メールは、Aさんの秘密鍵がないと復号化して平文にすることはできない
3. Aさんはメールを受信したら、PGPと秘密鍵を使って復号化してメールを読む