辞書を引くソフトぐらいメモ帳でつくれ

戻る

大したことをやってないわりには馬鹿長いコードになってしまった。
見る人が見れば分かるでしょうけど、英語の語形変化に手間取った結果です。
「ああ、こんな変化のしかたもあったっけ」で、行き当たりばったりに付け足しを繰り返しました。
本当はもっとコンパクトにまとめられるんだと思います。

Option Explicit 以下、全部コピーしてメモ帳に貼り付け、適当な名前で保存してみてください。
いや、本当にテキトーじゃ困るか。
"hoge.vbs"でも"foo.vbs"でもいいんですけど、尻尾に必ず".vbs"をくっつけて。"hoge"だけで保存すると只のメモ帳ファイルにされちゃう。
出来上がったvbsファイルがそのままソフト(とか言うといろんな人から怒られそう)、とりあえずダブルクリックで働き始めます。
ただその働きっぷりは本当に「とりあえず」で、辞書データベースがなければ仕事はことごとく空振りに終わる。
どんな単語でも返ってくる答は"No Data"です。
辞書をひきながら英文を読むソフト(その2)をダウンロードして解凍すると出てくる"kkwDICEJ"ファイルを、vbsファイルと同じ場所に持ってくるかコピーするかしてください。

冗談じゃねーぞ、辞書ぐらい自分でつくれねーでどーする、つべこべ言わずにメモ帳だけでつくるやりかた教えろ、という方はこちらへ。

ところで、これはちゃんとしたプログラミングツールで作ったものと違って「土台」を持ちません。
何か文字列をコピーすると、それに対する答としてメッセージボックスを出してくるだけです(このメッセージボックスは出しっぱなしのまま放置しておかないで、OK押してあげてください。でないと次の仕事に入れません)
メッセージボックスが出ていないときは本当に働いているのかどうか疑わしいほどで、起動中であることを忘れたままうっかりWindowsを終了させちゃうなんてこともありそうですけど、別に問題はないと思います(たぶん)

2行目、Const～3000とか50とかの数字は、こちらの気分でいい加減に決めたものなので、好きなように書き換えてください(Constの詳細はこちら)

注) vbsファイルを実行しないで単に中身を書き直す場合は、ダブルクリックじゃなく右クリックで「編集」を選択

Option Explicit
Const cTMINT = 3000, cMAXSTRLEN = 50, cTHRCNT = 100, cLOOPCNT = 1200, cSTRDIC = "kkwDICEJ"
Dim MyInc, MyCnt
Dim MyStrFromCLP, MyStrKP, MyStrRtn
MyStrFromCLP = GetStrFromCLP
If (MyStrFromCLP = "") Or (Len(MyStrFromCLP) > cMAXSTRLEN) Then
    MsgBox "---", vbOKOnly, "開始"
Else
    MyStrRtn = GetWordDataFromDic(LCase(MyStrFromCLP), cSTRDIC)
    MsgBox MyStrRtn, vbOKOnly, MyStrFromCLP
End If
MyCnt = 0
MyStrKP = MyStrFromCLP
For MyInc = 1 To cLOOPCNT
    WScript.Sleep (cTMINT)
    MyStrFromCLP = GetStrFromCLP
    If (MyStrFromCLP = "") Or (MyStrFromCLP = MyStrKP) Or (Len(MyStrFromCLP) > 50) Then
        MyCnt = MyCnt + 1
    Else
        MyStrRtn = GetWordDataFromDic(LCase(MyStrFromCLP), cSTRDIC)
        MyStrKP = MyStrFromCLP
        MsgBox MyStrRtn, vbOKOnly, MyStrFromCLP
    End If
    If MyCnt > cTHRCNT Then
        If MsgBox("終わりにしちゃっていい?", vbYesNo, "もう" & (cTMINT * cTHRCNT / 60000) & "分以上、辞書引いてないみたいだけど") = vbYes Then
            Exit For
        Else
            MyCnt = 0
        End If
    End If
Next
WScript.Quit

Function GetStrFromCLP
    Dim MyStr    
    On Error Resume Next
    MyStr = GetObject("\","htmlfile").ParentWindow.ClipboardData.GetData("text")
    If IsNull(MyStr) Then
        MyStr = ""
    End If
    GetStrFromCLP = MyStr
End Function

Function AddStrMatchWord(olvDbCnn, olvRst, strSrc, strTMP)
    Dim MyStr
    On Error Resume Next
    MyStr = strTMP
    olvRst.Open "SELECT TOP 5 fld1, fld2 FROM tbl00 WHERE fld1='" & strSrc & "' ORDER BY fld1", olvDbCnn
    If (olvRst.BOF = False) And (olvRst.EOF = False) Then
        olvRst.MoveFirst
        Do Until olvRst.EOF
            MyStr = MyStr & olvRst.Fields("fld1").Value & vbCrLf & Trim(olvRst.Fields("fld2").Value) & vbCrLf & vbCrLf
            olvRst.MoveNext
        Loop
    End If
    olvRst.Close
    AddStrMatchWord = MyStr
End Function

Function AddStrLLeftWord(olvDbCnn, olvRst, strSrc, strTMP)
    Dim MyStr
    On Error Resume Next
    MyStr = strTMP    
    olvRst.Open "SELECT TOP 5 fld1, fld2 FROM tbl00 WHERE fld1 Like '" & strSrc & "%' ORDER BY fld1", olvDbCnn
    If (olvRst.BOF = False) And (olvRst.EOF = False) Then
        olvRst.MoveFirst
        Do Until olvRst.EOF
            MyStr = MyStr & olvRst.Fields("fld1").Value & vbCrLf & Trim(olvRst.Fields("fld2").Value) & vbCrLf & vbCrLf
            olvRst.MoveNext
        Loop
    End If
    olvRst.Close
    AddStrLLeftWord = MyStr
End Function

Function CheckVWL(str)
    If (str = "a") Or (str = "e") Or (str = "i") Or (str = "o") Or (str = "u") Or (str = "") Then
        CheckVWL = True
    Else
        CheckVWL = False
    End If
End Function

Function CreateStrMatch(olvDbCnn, olvRst, strSrc)
    Dim MyStrRtn
    Dim MyStrRight(6)
    Dim MyStrFromR(6)
    Dim MyLen, MyInc
    MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, strSrc, "")
    MyLen = Len(strSrc)
    If MyLen < 3 Then
      CreateStrMatch = MyStrRtn
      Exit Function
    End If
    For MyInc = 1 To 6
      If MyLen < MyInc Then
        MyStrRight(MyInc) = ""
      Else
        MyStrRight(MyInc) = Right(strSrc, MyInc)
      End If
    Next
    For MyInc = 3 To 6
      If MyLen < MyInc Then
        MyStrFromR(MyInc) = ""
      Else
        MyStrFromR(MyInc) = Left(MyStrRight(MyInc), 1)
      End If
    Next
    If MyStrRight(1) = "s" Then
      MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
    End If
    If MyStrRight(1) = "y" Then
      If MyStrRight(2) = "ly" Then
        If MyStrRight(3) = "ily" Then
          MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3) & "y", MyStrRtn)
        Else
          If MyStrRight(3) = "lly" Then
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 2), MyStrRtn)
            If MyStrRight(5) = "fully" Then
              If MyLen > 5 Then
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5), MyStrRtn)
              End If
            End If
          Else
            If MyStrRight(5) = "ingly" Then
              If MyLen > 5 Then
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5) & "e", MyStrRtn)
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5), MyStrRtn)
                If MyLen > 6 Then
                  MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 6) & "e", MyStrRtn)
                  MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 6), MyStrRtn)
                End If
              End If
            Else
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1) & "e", MyStrRtn)
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 2), MyStrRtn)
            End If
          End If
        End If
      Else
        If MyStrRight(2) = "ty" Then
          If MyStrRight(3) = "ity" Then
            If MyStrRight(6) = "bility" Then
               MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 6) & "ble", MyStrRtn)
            Else
              If MyLen > 3 Then
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3) & "e", MyStrRtn)
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3), MyStrRtn)
              End If
            End If
          Else
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 2), MyStrRtn)
          End If
        Else
          MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
        End If
      End If
    Else
      If (MyStrRight(2) = "ed") Or (MyStrRight(2) = "er") Or (MyStrRight(2) = "es") Then
        If (MyStrRight(3) = "ied") Or (MyStrRight(3) = "ier") Or (MyStrRight(3) = "ies") Then
          MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3) & "y", MyStrRtn)
        Else
          If (CheckVWL(MyStrFromR(4)) = False) And (MyStrFromR(3) = MyStrFromR(4)) Then
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3), MyStrRtn)
          Else
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 2), MyStrRtn)
            If MyStrRight(3) = "ves" Then
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3) & "fe", MyStrRtn)
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3) & "f", MyStrRtn)
            End If
          End If
        End If
      Else
        If (MyStrRight(3) = "ing") Or (MyStrRight(3) = "est") Or (MyStrRight(3) = "ist") Or (MyStrRight(3) = "ers") Or (MyStrRight(3) = "ors") Then
          If MyStrRight(4) = "iest" Then
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4) & "y", MyStrRtn)
          Else
            If (CheckVWL(MyStrFromR(5)) = False) And (MyStrFromR(4) = MyStrFromR(5)) Then
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4) & "o", MyStrRtn)
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4) & "e", MyStrRtn)
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4), MyStrRtn)
            Else
              If MyLen > 3 Then
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3) & "o", MyStrRtn)
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3) & "e", MyStrRtn)
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3), MyStrRtn)
              End If
            End If
          End If
        Else
          If (MyStrRight(4) = "ings") Or (MyStrRight(4) = "ists") Then
            If (CheckVWL(MyStrFromR(6)) = False) And (MyStrFromR(5) = MyStrFromR(6)) Then
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5) & "o", MyStrRtn)
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5) & "e", MyStrRtn)
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5), MyStrRtn)
            Else
              If MyLen > 3 Then
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4) & "o", MyStrRtn)
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4) & "e", MyStrRtn)
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4), MyStrRtn)
              End If
            End If
          Else
            If (MyStrRight(4) = "full") Or (MyStrRight(4) = "ness") Or (MyStrRight(4) = "less") Or (MyStrRight(4) = "able") Or (MyStrRight(4) = "ably") Or (MyStrRight(4) = "ment") Then
              MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4), MyStrRtn)
              If MyStrRight(4) = "ably" Then
                MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 4) & "able", MyStrRtn)
              Else
                If MyLen > 5 Then
                  If MyStrFromR(5) = "i" Then
                    MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5) & "y", MyStrRtn)
                  End If
                End If
              End If
            Else
              If MyStrRight(5) = "ments" Then
                If MyLen > 5 Then
                  MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 5), MyStrRtn)
                End If
              End If
            End If
          End If
        End If
      End If
    End If
    If MyStrRtn = "" Then
      MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
      If MyStrRtn = "" Then
        MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 2), MyStrRtn)
        If MyStrRtn = "" Then
          If MyLen > 3 Then
            MyStrRtn = AddStrMatchWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3), MyStrRtn)
          End If
        End If
      End If
    End If
    If MyStrRtn = "" Then
      MyStrRtn = AddStrLLeftWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 1), MyStrRtn)
      If MyStrRtn = "" Then
        MyStrRtn = AddStrLLeftWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 2), MyStrRtn)
        If MyStrRtn = "" Then
          If MyLen > 3 Then
            MyStrRtn = AddStrLLeftWord(olvDbCnn, olvRst, Left(strSrc, MyLen - 3), MyStrRtn)
          End If
        End If
      End If
    End If
    CreateStrMatch = MyStrRtn
End Function

Function GetWordDataFromDic(strSrc, strDicDB)
    Dim MyDbCnn, MyRst
    Dim MyStrRtn, MyStrCnv, MyStrLeft2, MyStrLeft3
    Dim MyChk
    Dim MyFSO    
    On Error Resume Next
    MyStrRtn = ""
    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    MyChk = MyFSO.FileExists(strDicDB)
    Set MyFSO = Nothing
    If MyChk = True Then
        Set MyDbCnn = CreateObject("ADODB.Connection")
        MyDbCnn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" + strDicDB + "'")
        Set MyRst = CreateObject("ADODB.Recordset")
        MyStrRtn = CreateStrMatch(MyDbCnn, MyRst, strSrc)
        If MyStrRtn = "" Then
            MyStrLeft2 = Left(strSrc, 2)
            MyStrLeft3 = Left(strSrc, 3)
            MyStrCnv = ""
            If (MyStrLeft2 = "en") Or (MyStrLeft2 = "un") Or (MyStrLeft2 = "re") Or (MyStrLeft3 = "irr") Then
                MyStrCnv = Right(strSrc, Len(strSrc) - 2)
            Else
                If MyStrLeft3 = "dis" Then
                    MyStrCnv = Right(strSrc, Len(strSrc) - 3)
                End If
            End If
            If Len(MyStrCnv) > 0 Then
                MyStrRtn = CreateStrMatch(MyDbCnn, MyRst, MyStrCnv)
            End If
        End If
        MyDbCnn.Close
        Set MyRst = Nothing
        Set MyDbCnn = Nothing
    End If
    If MyStrRtn = "" Then
        MyStrRtn = "No Data"
    End If
    GetWordDataFromDic = MyStrRtn
End Function

で、余談。

「マシンを動かす命令文のかたまり」= ソフト = アプリ = プログラム ≒ EXEファイル(おもにEXE、場合によってはVBS、JSも)
と、自分はそういう認識でして、これらの単語を意図的に使い分けていないというか意図的に混乱した使い方をしているというか、要は同じ意味の言葉として使っています。

たぶんEXEファイル一個で済むようなソフトしか作ったことがないせいで、そのために、たとえば「インストール」という言葉の使われ方に違和感を覚えることが多かったりもします。
アプリケーションをインストールする?
何だそれ、って感じ。
単純に和訳して、「設置する」「置く」のほうがずっとしっくりくる。
もっとしっくりくるのは「(ここに)もってくる」「コピーする」「EXEファイルを適当な場所にコピーする」

あと、まともなプログラミングツールで書いたものを「プログラム」、メモ帳のような簡易ツールで書いたものを「スクリプト」と使い分ける習慣が一部であるようですけど、全部プログラムでいいじゃんとか思ってます。

こういう無神経なものの言い方を不快に感じる人がいたら、この場を借りて謝罪します。
ただ反省とか善処はしないような気がします。