kansaku_form.frm

けんさくするようのかんたんなプログラムです

      Width           =   1200
   End
   Begin VB.Label Label1 
      Caption         =   "上 位 概 念 1"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Index           =   0
      Left            =   2700
      TabIndex        =   10
      Top             =   1600
      Width           =   1200
   End
End
Attribute VB_Name = "kansaku_form"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cancel_com_Click()
End

End Sub




Private Sub downcombo1_Click(Index As Integer)
Dim i As Integer, str2 As String

If downcombo1(Index).Text = "" Then
    Exit Sub
End If
For i = 0 To 3
    If Option1(i).Value = True Then
        str2 = Option1(i).Caption
        Exit For
    End If
Next
If M_count(Trim(upcombo1(Index).Text), str2, downcombo1(Index).Text, 2 + Index) = 1 Then
End If
End Sub

Private Sub downcombo1_GotFocus(Index As Integer)
Dim str1 As String, str2 As String, i As Integer
On Error Resume Next
If upcombo1(Index).Text = "" Then Exit Sub
    downcombo1(1).Clear
    downcombo1(1).Text = ""
    downcombo1(0).Clear
    downcombo1(0).Text = ""
str1 = upcombo1(Index)
For i = 0 To 3
    If Option1(i).Value = True Then
        str2 = Option1(i).Caption
    End If
Next
If M_Access(str1, str2, 1, Index) = 1 Then

Else
    MsgBox "没有符合要求的数据", vbOKOnly + 16, "提示信息"
End If
End Sub

Private Sub Form_Load()
Dim s_Arr() As String
'    If Dir(App.Path + "/TEXT.txt") <> "" Then
'        Open App.Path + "/TEXT.txt" For Input As #1
'            Do While Not EOF(1)
'                Line Input #1, s_Line
'                s_Arr = Split(s_Line, "=")
'                If Trim(s_Arr(0)) = "%text1%" And UBound(s_Arr) = 1 Then
'                    upcombo1(0) = Trim(s_Arr(1))
'                End If
'                If Trim(s_Arr(0)) = "%text2%" And UBound(s_Arr) = 1 Then
'                    upcombo1(1) = Trim(s_Arr(1))
'                End If
'                If Trim(s_Arr(0)) = "%text3%" And UBound(s_Arr) = 1 Then
'                    downcombo1(0) = Trim(s_Arr(1))
'                End If
'                If Trim(s_Arr(0)) = "%text4%" And UBound(s_Arr) = 1 Then
'                    downcombo1(1) = Trim(s_Arr(1))
'                End If
'            Loop
'        Close #1
'    End If
End Sub



Private Sub OK_com_Click()
Dim InputData
Dim str1 As String
For i = 0 To 3
    If Option1(i).Value = True Then
        If downcombo1(0).Text = "" Then
            str1 = upcombo1(1) & Option1(i).Caption & downcombo1(1)
        Else
            str1 = upcombo1(0) & Option1(i).Caption & downcombo1(0)
            Exit For
        End If
    End If
Next

Open App.Path + "/text1.txt" For Output As #2  ' 为输入打开文件。
'Do While Not EOF(2)   ' 检查文件尾。
   Write #2, str1
   'Line Input #2, str1   ' 读入一行数据。
   Debug.Print str1   ' 在立即窗口中显示。
'Loop
Close #2   ' 关闭文件。

End Sub

Private Sub Option1_Click(Index As Integer)
If Index = 0 Or Index = 1 Then
    Option1(2).Value = False
    Option1(3).Value = False
    Exit Sub
End If
If Index = 2 Or Index = 3 Then
    Option1(0).Value = False
    Option1(1).Value = False
    Exit Sub
End If
End Sub

Public Function M_Access(S_word As String, S_link As String, I_count1 As Integer, I_count2 As Integer)
Dim M_temp As String
Dim M_Error As String
    Dim conn As ADODB.Connection         '定义连接
    Dim rs As ADODB.Recordset       '定义数据集
    Dim i As Integer, str1 As String, s_StrSQL As String
On Error GoTo ine
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
'Set conn = New Connection
'Set rs = New ADODB.Recordset
M_temp = ""
M_temp = App.Path + "\book.mdb;"
conn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & M_temp & ";"
If I_count1 = 1 Then
    rs.LockType = adLockReadOnly            'Read Only
    s_StrSQL = "select downword from booktable where upword = '" & S_word & "' and linkword = '" & S_link & "';"
    rs.Open s_StrSQL, conn, adOpenStatic, adLockReadOnly
    'Set rs = conn.Execute("select downword from booktable where upword = '" & S_word & "' and linkword = '" & S_link & "';")
    If rs.RecordCount = 0 Then
        M_Access = 0
        rs.Close
        conn.Close
        Exit Function
    End If
    For i = 0 To rs.RecordCount - 1
        str1 = rs.Fields("downword").Value
        downcombo1(I_count2).AddItem str1 'rs.Fields(i * 2 - 1).Value
        If i = 0 Then
            downcombo1(I_count2).Text = str1
        End If
        rs.MoveNext
    Next
Else
    rs.LockType = adLockReadOnly            'Read Only
    s_StrSQL = "select upword from booktable where downword = '" & S_word & "' and linkword = '" & S_link & "';"
    rs.Open s_StrSQL, conn, adOpenStatic, adLockReadOnly
    If rs.RecordCount = 0 Then
        M_Access = 0
        rs.Close
        conn.Close
        Exit Function
    End If
    For i = 0 To rs.RecordCount - 1
        str1 = rs.Fields("upword").Value
        upcombo1(I_count2).AddItem str1 'rs.Fields(i * 2 - 1).Value
        rs.MoveNext
        If i = 0 Then
            upcombo1(I_count2).Text = str1
        End If
    Next
End If
rs.Close
conn.Close
M_Access = 1
GoTo inerr
ine:
   M_Error = "错误：" & Err.Number & "DB搜索失败！" & Err.Description
   MsgBox M_Error, , "worning"
   M_Access = -1
inerr:
Set rs = Nothing
End Function


Private Sub upcombo1_Click(Index As Integer)
Dim i As Integer, str2 As String

If upcombo1(Index).Text = "" Then
    Exit Sub
End If
For i = 0 To 3
    If Option1(i).Value = True Then
        str2 = Option1(i).Caption
        Exit For
    End If
Next
If M_count(Trim(upcombo1(Index).Text), str2, downcombo1(Index).Text, Index) = 1 Then
End If
End Sub

Private Sub upcombo1_GotFocus(Index As Integer)
Dim str1 As String, str2 As String, i As Integer
On Error Resume Next
If downcombo1(Index).Text = "" Then Exit Sub
    upcombo1(1).Clear
    upcombo1(1).Text = ""
    upcombo1(0).Clear
    upcombo1(0).Text = ""
str1 = downcombo1(Index)
For i = 0 To 3
    If Option1(i).Value = True Then
        str2 = Option1(i).Caption
    End If
Next
If M_Access(str1, str2, 2, Index) = 1 Then

Else
    MsgBox "没有符合要求的数据", vbOKOnly + 16, "提示信息"
End If
End Sub


Public Function M_count(S_upword As String, S_link As String, S_downword As String, I_count2 As Integer)
Dim M_temp As String
Dim M_Error As String
    Dim conn As ADODB.Connection         '定义连接
    Dim rs As ADODB.Recordset       '定义数据集
    Dim i As Integer, str1 As String, s_StrSQL As String
On Error GoTo ine
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
M_temp = ""
M_temp = App.Path + "\book.mdb;"
conn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & M_temp & ";"
    rs.LockType = adLockReadOnly            'Read Only
    s_StrSQL = "select count from booktable where upword = '" & S_upword & "' and linkword = '" & S_link & "' and downword = '" & S_downword & "';"
    rs.Open s_StrSQL, conn, adOpenStatic, adLockReadOnly
    If rs.RecordCount = 0 Then
        M_count = 0
        rs.Close
        conn.Close
        Exit Function
    End If
        str1 = rs.Fields("count").Value
        Text1(I_count2).Text = str1
rs.Close
conn.Close
M_count = 1
GoTo inerr
ine:
   M_Error = "错误：" & Err.Number & "DB搜索失败！" & Err.Description
   MsgBox M_Error, , "worning"
   M_count = -1
inerr:
Set rs = Nothing
End Function