万能查询frm.frm

Mdb数据库万能查询 功能强大 功能:智能查询、模拟查询当前目录下*.mdb数据库文件

    
    MyViewBoolean = True '设置可打印预览

End Sub

Private Sub Command1_Click()
    Dim MyAppPath As String
    On Error Resume Next
    MyAppPath = MyAppPath & "查询.txt"
    s = Shell("C:\Program Files\Microsoft Office\Office\EXCEL.EXE" & " " _
        & MyAppPath, vbNormalFocus) 'Excel97、Excel2000默认的安装路径
    If Err.Number = 53 Then
        s = Shell("C:\Program Files\Microsoft Office\Office11\EXCEL.EXE" & " " _
            & MyAppPath, vbNormalFocus) 'Excel2003默认的安装路径
    End If
End Sub

Private Sub Command1_gotFocus()
    MyTxt = "查询.txt"
    MyGotfocus
End Sub


Private Sub Command2_Click()
'Excel97引用Microsoft Excel 8.0 Object Library库，Excel2000以上引用Microsoft Excel 9.0 Object Library
On Error Resume Next
Dim myxcl As Excel.Application
Set myxcl = CreateObject("Excel.Application")

    With myxcl
        .Workbooks.OpenText FileName:=MyAppPath _
            & "打印.txt", StartRow:=1, DataType:=xlDelimited, Tab:=True
        .Range("A1:A2").EntireRow.Insert
        .Range("A1").Value = MyRecordsetName
        .Range("A1").Font.Size = 18
        .Range("A1").Font.Name = "隶书"
    
        .Range("A1").Resize(, MyDatabaseFieldsCount).HorizontalAlignment = xlCenter
        .Range("A1").Resize(, MyDatabaseFieldsCount).Merge
        
        .Range("A4").CurrentRegion.Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Range("A4").CurrentRegion.Borders(xlEdgeTop).LineStyle = xlContinuous
        .Range("A4").CurrentRegion.Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Range("A4").CurrentRegion.Borders(xlEdgeRight).LineStyle = xlContinuous
        .Range("A4").CurrentRegion.Borders(xlInsideVertical).LineStyle = xlContinuous
        .Range("A4").CurrentRegion.Borders(xlInsideHorizontal).LineStyle = xlContinuous
    
        For i = 1 To MyDatabaseFieldsCount '根据数据网格各列的宽度调整电子表格各列宽度
        .Cells(2, i).ColumnWidth = MSFlexGrid1.ColWidth(i - 1) * 60 / 11280
        Next
        
        .ActiveSheet.PageSetup.PrintTitleRows = "$1:$3"
        .ActiveSheet.PageSetup.PrintTitleColumns = "$A:$A"
        .ActiveSheet.PageSetup.PaperSize = xlPaperA4
        .ActiveSheet.PageSetup.CenterFooter = "第 &P 页，共 &N 页　　&D"
        .ActiveSheet.PageSetup.CenterHorizontally = True
        
        If MyViewBoolean Then '供预览
            .Visible = True
            .ActiveWindow.SelectedSheets.PrintPreview
        Else
            .ActiveWindow.SelectedSheets.PrintOut Copies:=1
        End If
        .ActiveWindow.Close Save = True
        .Quit
    End With
    
    Set myxcl = Nothing
End Sub

Private Sub Command2_gotFocus()
    MyTxt = "打印.txt"
    MyGotfocus
End Sub

Private Sub Command3_Click()
    On Error Resume Next
    MSFlexGrid1.Visible = False
    
    Dim i As Integer

    ssss = ""
        
    For i = 0 To MSFlexGrid1.Cols - 1
        ssss = ssss & Trim(Text1(i).Text)
    Next
        
    If ssss = "" Then
        MsgBox "请输入内容，然后按“查询”按扭或者按回车！", , "提示信息"
        MSFlexGrid1.Visible = True
        Command1.Enabled = False
        Command2.Enabled = False '报表
        Exit Sub
    End If

    s = ""
    
    For i = 0 To MyDatabaseFieldsCount - 1
        If Trim(Text1(i).Text) <> "" Then
            If s = "" Then
                s = "where " & Label1(i).Caption
            Else
                s = s & " and " & Label1(i).Caption
            End If
            
            Select Case RstFieldsType(i)
                Case 1      '是否类型值为1
                Case 2, 3, 4, 5, 6, 7
                '数字类型和自动编号类型值为4
                    If (Left(Trim(Text1(i).Text), 1) = ">=" _
                            Or Left(Trim(Text1(i).Text), 1) = "<=") _
                            And IsNumeric(Mid(Trim(Text1(i).Text), 3, 20)) Then
                       s = s & Left(Trim(Text1(i).Text), 2) _
                            & Mid(Trim(Text1(i).Text), 3, 20)
                    ElseIf (Left(Trim(Text1(i).Text), 1) = ">" _
                                Or Left(Trim(Text1(i).Text), 1) = "<") _
                                And IsNumeric(Mid(Trim(Text1(i).Text), 2, 20)) Then
                       s = s & Left(Trim(Text1(i).Text), 1) _
                            & Mid(Trim(Text1(i).Text), 2, 20)
                    ElseIf Not IsNumeric(Trim(Text1(i).Text)) Then
                        MsgBox "你在“" & Label1(i).Caption _
                            & "”中输入的“" & Text1(i).Text _
                            & "”不是数据格式，请重输！！！", 48, "差错信息！！！"
                        Exit Sub
                    Else
                       s = s & "=" & Trim(Text1(i).Text)
                    End If
                'Case 5      '货币类型值为5
                Case 8      '日期/时间类型值为8
                    If (Left(Trim(Text1(i).Text), 1) = ">=" _
                            Or Left(Trim(Text1(i).Text), 1) = "<=") _
                            And IsDate(Mid(Trim(Text1(i).Text), 3, 20)) Then
                       s = s & Left(Trim(Text1(i).Text), 2) & "#" _
                            & Mid(Trim(Text1(i).Text), 3, 20) & "#"
                    ElseIf (Left(Trim(Text1(i).Text), 1) = ">" _
                            Or Left(Trim(Text1(i).Text), 1) = "<") _
                            And IsDate(Mid(Trim(Text1(i).Text), 3, 20)) Then
                       s = s & Left(Trim(Text1(i).Text), 1) & "#" & _
                            Mid(Trim(Text1(i).Text), 2, 20) & "#"
                    ElseIf Not IsDate(Trim(Text1(i).Text)) Then
                    MsgBox "你在“" & Label1(i).Caption & "”中输入的“" & _
                        Text1(i).Text & "”不是数值格式，请重输！！！", 48, "差错信息！！！"
                        Exit Sub
                    Exit Sub
                    
                    Else
                       s = s & "=" & "#" & Trim(Text1(i).Text) & "#"
                    End If
                Case 10     '文本类型值为10
                    s = s & " like '*" & Trim(Text1(i).Text) & "*'"
                Case 11     'OLE则对象类型值为11
                Case 12     '备注类型和超级连接类型值为12
                Case Else
            End Select
        End If
    Next i
    
    s = "select * from " & MyRecordsetName & " " & s
    
    Dim dbs As Database, rst As Recordset
    '初始化
    Set dbs = OpenDatabase(MyDatabasePathAndName)
    Set rst = dbs.OpenRecordset(s)
    MyDatabaseRecordCount = rst.RecordCount
     
    If rst.BOF Then
        MSFlexGrid1.Rows = 1
        Me.Caption = "数据库（" & _
            Dir(MyDatabasePathAndName) & "）————" & "表（" & _
            MyRecordsetName & "）————查出" & 0 & "条记录"
        Command1.Enabled = False
        Command2.Enabled = False '报表
        MSFlexGrid1.Visible = True
        MsgBox "没有查询结果！", , "提示信息"
        Exit Sub
    End If
    rst.MoveFirst
    i = 0
    MSFlexGrid1.Rows = 1
    MSFlexGrid1.Visible = False
    
    Do
        MSFlexGrid1.Rows = MSFlexGrid1.Rows + 1
        i = i + 1
        For ii = 0 To MyDatabaseFieldsCount - 1
            MSFlexGrid1.TextMatrix(i, ii) = rst.Fields(ii)
        Next
        rst.MoveNext
    Loop Until rst.EOF
    MSFlexGrid1.Visible = True
    
    If i < 1 Then
        Command1.Enabled = False
        Command2.Enabled = False '报表
    
    Else
        Command1.Enabled = True
        Command2.Enabled = True '报表
    End If
    Me.Caption = "数据库（" & Dir(MyDatabasePathAndName) & "）————" _
        & "表（" & MyRecordsetName & "）————查出" & i & "条记录"
    MSFlexGrid1.Refresh
    MSFlexGrid1.Visible = True
End Sub

Private Sub Command4_Click()
    On Error Resume Next
    For i = 0 To MyDatabaseFieldsCount - 1
        Text1(i).Text = ""
    Next
    Command1.Enabled = False '打开
    Command2.Enabled = False '打印
    Command4.Enabled = False '清除
End Sub

Private Sub Command5_Click()
    End
End Sub

Private Sub MSFlexGrid1_Click()
    On Error Resume Next
    '单击数据网格时，显示当前数据
    For i = 1 To MyDatabaseFieldsCount
        Text1(i - 1).Text = MSFlexGrid1.TextMatrix(MSFlexGrid1.RowSel, i - 1)
    Next
    Command4.Enabled = True '清除
End Sub

Private Sub MSFlexGrid1_DblClick()
    '双击数据网格时，排队序时列
    Static i As Integer
    If i = 1 Then
        i = i + 1
    Else
        i = 1
    End If
    MSFlexGrid1.Sort = i
End Sub

Private Sub Text1_Change(Index As Integer)
    Command4.Enabled = True '清除
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    Text1(Index).SelStart = 0
    Text1(Index).SelLength = Len(Text1(Index).Text) '全选
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
    If KeyAscii = 13 Then Command3.Value = True:  KeyAscii = 0
End Sub

Private Sub FieldLook() '核对数据类型
    FieldLookValue = True  '暂设数据类型正确
    For i = 0 To MyDatabaseFieldsCount - 1 - 3
        Select Case RstFieldsType(i)
            Case 1      '是否类型值为1
            Case 2, 3, 4, 5, 6, 7
            '数字类型和自动编号类型值为4
                If Not (IsNumeric(Trim(Text1(i).Text)) Or Trim(Text1(i).Text) = "") Then
                
                   FieldLookValue = False '数据类型错误
                   MsgBox "你在“" & Label1(i).Caption & "”中输入的“" _
                        & Text1(i).Text & "”不是数值格式，请重输！！！", 48, "差错信息！！！"
                End If
            'Case 5      '货币类型值为5
            Case 8      '日期/时间类型值为8
                If Not (IsDate(Trim(Text1(i).Text)) Or Trim(Text1(i).Text) = "") Then
                
                   FieldLookValue = False数据类型错误
                   MsgBox "你在“" & Label1(i).Caption & "”中输入的“" _
                        & Text1(i).Text & "”不是日期格式，请重输！！！", 48, "差错信息！！！"
                End If
            
            Case 10     '文本类型值为10
            Case 11     'OLE则对象类型值为11
            Case 12     '备注类型和超级连接类型值为12
            Case Else
        End Select
    Next
End Sub
Private Sub MyGotfocus()
    '当“电子表格打开”按钮获得焦点时，把当前查询结果暂存
    On Error Resume Next
    Dim i As Integer
    Dim j As Integer
    
    Dim fso As New FileSystemObject
    Dim txtfile As TextStream
    Dim dbs As Database, rst As Recordset
    
    Set dbs = OpenDatabase(MyDatabasePathAndName)
    Set rst = dbs.OpenRecordset(s)
    Set txtfile = fso.OpenTextFile(MyAppPath & MyTxt, ForWriting, True)
   
    If Not rst.EOF Then rst.MoveLast
    If Not rst.BOF Then rst.MoveFirst
    For j = 0 To rst.Fields.Count - 1
        txtfile.Write rst.Fields(j).Name & Chr(9)
    Next
    txtfile.Write vbCrLf
    
    For i = 1 To rst.RecordCount
        For j = 0 To rst.Fields.Count - 1
           If IsNull(rst.Fields(j).Value) Then
                txtfile.Write "" & Chr(9)
            Else
               txtfile.Write rst.Fields(j).Value & Chr(9)
            End If
        Next
        If Not rst.EOF Then rst.MoveNext
        txtfile.Write vbCrLf
    Next

End Sub
Private Sub Command1gotFocus()
    MyTxt = "查询.txt"
    MyGotfocus
End Sub

Private Sub Command2GotFocus()
    MyTxt = "打印.txt"
    MyGotfocus
End Sub