アルツの備忘録

最近、年のせいで物忘れが激しい。
そこで、いろんなことをここに記録して行きたいと思います。

Access　和英・英和翻訳　Web辞書サーバ作成

2008年02月16日 00時43分38秒 | Access
ＡｃｃｅｓｓＶＢＡでwinsockを使いWeb翻訳サーバを作った。
ブラウザでこのサーバを呼び出し、文字を送ると英和・和英の翻訳を行う・・といったものです。

＜仕様＞
待ち受けのポートは初期値は８０番だが変更可能とした。
検索側は、ブラウザで行う、サーバ側のポートが８０以外の時は、　http://サーバ名：ポート番号　で呼び出す。
翻訳テーブルは、「PrepTutorEJDIC」をAccessのテーブルに取り込んだ。（約４６７００語）
翻訳対象の文字が全角か半角かで和英・英和の変換を判断
英和は前方一致、和英はその文字が含まれるかで検索した。

実験結果覚書
　　ブラウザにデータを送るとき、VBでは問題なかったがAccessdeは文字化けが起こった、バイナリーで送ったら直った。

------------------------
Option Compare Database
Option Explicit                  '変数宣言を強制する
Dim CpName As String
Dim sendHTML As String
Dim strData As String
Dim Whtml As String
    
Private Sub Form_Unload(Cancel As Integer)
'閉じる時、WINSOCKを閉じる
    Winsock1.Close
    Winsock2.Close
End Sub

Private Sub コマンド0_Click() '終了処理
    Winsock1.Close            'ネットワーク切断
    Winsock2.Close
    DoCmd.Close
    Quit
End Sub
Private Sub コマンド16_Click()
'使用ポート変更
On Error GoTo err_end:

    Me.テキスト11 = ""
    Me.テキスト1 = ""
    Me.テキスト2 = ""
    Winsock1.Close                        '終了処理
    Winsock1.LocalPort = Me.テキスト14    '接続要求受付ポート番号設定
    Winsock1.Listen                       '接続要求待ち
    Exit Sub
err_end:
    MsgBox ("Winsock待ちエラー")
    Winsock1.Close
End Sub

Private Sub Form_Load()
On Error GoTo err_end:
    Me.テキスト14 = 80
    Winsock1.Close             '終了処理
    Winsock1.LocalPort = 80    '接続要求受付ポート番号設定
    Winsock1.Listen            '接続要求待ち

    'コンピュータ名を得る
    Dim obj
    Set obj = CreateObject("WScript.Network")
    CpName = obj.ComputerName
    Me.テキスト17 = CpName
    
   'Html
    Whtml = "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.01 Transitional//EN'"
    Whtml = Whtml & "'http://www.w3.org/TR/1999/REC-html401-19991224/loose.dtd'>"
    Whtml = Whtml & "<html lang='ja'>"
    Whtml = Whtml & "<head>"
    Whtml = Whtml & "<meta http-equiv='Content-Type' content='text/html; charset=Shift_JIS'>"
    Whtml = Whtml & "<meta http-equiv='Content-Script-Type' content='text/javascript'>"
    Whtml = Whtml & "<meta http-equiv='Content-Style-Type' content='text/css'>"
    Whtml = Whtml & "<TITLE>翻訳</TITLE></HEAD><BODY><center>"
    Whtml = Whtml & "<FORM name='form1' action='http://"
    Whtml = Whtml & Me.テキスト17
    Whtml = Whtml & ":"
    Whtml = Whtml & Me.テキスト14
    Whtml = Whtml & "/' METHOD='POST'>"
    Whtml = Whtml & "<br><br> 英和・和英翻訳<br><br>"
    
    Exit Sub
err_end:
    Winsock1.Close
    MsgBox ("Winsock待ちエラー")
End Sub

'------------------------------

'ブラウザ処理
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)

    'ブラウザからWinsock1へのの接続要求があった時、
    'Winsock2が閉じていなければクローズ処理を行ってから接続処理を実行
    If Winsock2.State <> sckClosed Then Winsock2.Close
    
    '応答処理をWinsock2へ引き渡す
    Winsock2.Accept requestID
    'メッセージ表示
    msg_write ("Winsock1 ConnectionRequest = " & requestID)

End Sub

Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
'データ受信処理
    Dim kubun As String
    Dim kugiri As Double
    
    'ブラウザからのリクエスト
    Winsock2.GetData strData, vbString
    'メッセージ表示
    msg_write ("Winsock2 DataArrival = " & strData)
    
    If strData = "" Then
        Get_Shori
        msg_write ("Winsock2 DataArrival Data= なし")
        Exit Sub
    End If
    
    '通信区分を得る
    kugiri = InStr(1, strData, " ")
    If kugiri = 0 Then
      '大量データの場合、データが分割されて届く場合がある。
       Exit Sub
    End If
    
    kubun = Left(strData, InStr(1, strData, " ") - 1)
    
    Select Case kubun
       Case "GET"
             Get_Shori
       Case "POST"
             POST_data
       Case Else
             Get_Shori
    End Select
        
End Sub

Public Sub POST_data()
    Dim kubun1 As Integer
    Dim kubun2 As Integer
    Dim Mword As String
    Dim Gword As String
    'POSTデータ編集
    kubun1 = InStr(1, strData, "Mword=")
    If kubun1 = 0 Then
        Mword = ""
     Else
        kubun2 = InStr(kubun1, strData, "&")
        If kubun2 = 0 Then
             Mword = Trim(Mid(strData, kubun1 + 6))
           Else
             Mword = Trim(Mid(strData, kubun1 + 6, (kubun2 - (kubun1 + 6))))
        End If
    End If
    
    If Mword <> "" Then
        'POST文字変換
        Mword = PostHenkan(Mword)
        'データ検索処理
        Gword = Honyaku(Mword)
        Me.テキスト1 = Mword
        Me.テキスト2 = Gword
      Else
        Gword = "わかりません"
    End If
    
    'Html
    sendHTML = Whtml & "変換前<br><INPUT size='20' type='text' name='Mword' value='" & Mword & "'>"
    sendHTML = sendHTML & "　<INPUT type='submit' value='送信'><br><br>"
    sendHTML = sendHTML & "</FORM>"
    sendHTML = sendHTML & "変換後<br><textarea name='Gword' cols='80' rows='20' wrap='hard'>" & Gword & "</textarea>"
    sendHTML = sendHTML & "</center></body></html>"
    
   'データ編集
    Dim mm_send_data As String
    mm_send_data = "HTTP/1.1 200 OK" & vbCrLf & _
                    "Connection: close" & vbCrLf & _
                    "Content-type: text/html" & vbCrLf & _
                    vbCrLf & _
                    "" & sendHTML & ""
    'メッセージ表示
    msg_write ("Winsock2 POST_Shori = " & mm_send_data)
    'バイナリ変換
    Dim strbuf() As Byte
    strbuf = StrConv(mm_send_data, vbFromUnicode)
                    
    'データ転送
    Me.Winsock2.SendData strbuf

End Sub

Public Sub Get_Shori()
'翻訳応答用メニューを返す。
        
    'Html
    sendHTML = Whtml & "変換前<br><INPUT size='20' type='text' name='Mword' value=''>"
    sendHTML = sendHTML & "　<INPUT type='submit' value='送信'><br><br>"
    sendHTML = sendHTML & "</FORM>"
    sendHTML = sendHTML & "変換後<br><textarea name='Gword' cols='80' rows='20' wrap='hard'></textarea>"
    sendHTML = sendHTML & "</center></body></html>"
    
    '応答データ編集
    Dim mm_send_data As String
    mm_send_data = "HTTP/1.1 200 OK" & vbCrLf & _
                    "Connection: close" & vbCrLf & _
                    "Content-type: text/html" & vbCrLf & _
                    vbCrLf & _
                    "" & sendHTML & ""
    'メッセージ表示
    msg_write ("Winsock2 Get_Shori = " & mm_send_data)
    
    'バイナリ変換
    Dim strbuf() As Byte
    strbuf = StrConv(mm_send_data, vbFromUnicode)
    'データ転送
    Me.Winsock2.SendData strbuf

End Sub

Private Sub msg_write(wdate)
'デバック用メッセージ表示
    Me.テキスト11 = Me.テキスト11 & wdate & vbCrLf
    Me.テキスト11 = Me.テキスト11 & "---------------------------" & vbCrLf
    
    'テキストを最終行に位置ずける
    Me.テキスト11.SetFocus
    Me.テキスト11.SelStart = Len(Me.テキスト11)
End Sub

Private Sub Winsock2_SendComplete()
    'データ転送終了時にクローズ処理
    Winsock2.Close
End Sub

'POST文字変換処理
※省略

'-------------------------------------
'翻訳処理
Function Honyaku(Hword)
    Dim dat As String, ans As String
    Dim n As Integer
    
    '英和/和英 変換
    ans = Tango_chk(Hword)
    
    '翻訳結果を戻す
    If ans <> "" Then
        Honyaku = Trim(ans)
      Else
        Honyaku = "わかりません"
    End If
End Function

Function Tango_chk(dat)
    
    Dim db As Database
    Dim rs As Recordset
    Dim Tango As String
    Dim moji As String
    
    Set db = CurrentDb
    
    '検索文字が全角のとき、和英変換
    '半角のとき、英和変換
    moji = Left(dat, 1)
    If LenB(StrConv(moji, vbFromUnicode)) = 2 Then
        Set rs = db.OpenRecordset("SELECT * FROM Tango where 日本語 like '*" & dat & "*'")
      Else
        Set rs = db.OpenRecordset("SELECT * FROM Tango where 英語 like '" & dat & "*'")
    End If
        
    'データが一件でもあるか
    Tango = ""
    If Not rs.EOF Then
       Do While Not rs.EOF
          Tango = Tango & rs!英語 & " ： " & rs!日本語 & vbCrLf
          rs.MoveNext
       Loop
    End If
    
    Tango_chk = Tango
    
    '後処理
    rs.Close
    db.Close

End Function




最新の画像［もっと見る］

コメントを投稿