VB快捷查看錶結構和表資料

VB快捷查看錶結構和表資料
 小弟經常查看資料庫裡面的資料查看錶資料，要用對sql server 要有企業管理器或查詢分析器對oracle 用 sql plus ， 來回切換真麻煩，於是編了一個資料庫查看器只針對 ms sql server 和 oracle 資料庫，採用oledb串連資料庫本程式為VB程式，使用了 Microsoft Internet Controls 和 Microsoft Windows Common Controls 6.0的控制項陳列庫此外還引用了 Microsoft ActiveX Data Objects 2.5 Library , Microsoft OLE DB Service Component 1.0 Type Library 的引用程式使用者介面為VERSION 5.00Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "shdocvw.dll"Begin VB.Form frmViewData    Caption         =   "Form1"   ClientHeight    =   6780   ClientLeft      =   60   ClientTop       =   345   ClientWidth     =   9630   Icon            =   "frmViewData.frx":0000   LinkTopic       =   "Form1"   ScaleHeight     =   6780   ScaleWidth      =   9630   StartUpPosition =   2  'CenterScreen   Begin VB.CommandButton cmdMin       Caption         =   "最小值"      Height          =   390      Left            =   7680      TabIndex        =   11      Top             =   0      Width           =   885   End   Begin VB.CommandButton cmdMax       Caption         =   "最大值"      Height          =   390      Left            =   6735      TabIndex        =   10      Top             =   0      Width           =   930   End   Begin VB.CommandButton cmdCount       Caption         =   "查詢記錄個數"      Height          =   390      Left            =   5325      TabIndex        =   9      Top             =   0      Width           =   1380   End   Begin SHDocVwCtl.WebBrowser myGrid       Height          =   3525      Left            =   3330      TabIndex        =   8      Top             =   3060      Width           =   5070      ExtentX         =   8943      ExtentY         =   6218      ViewMode        =   0      Offline         =   0      Silent          =   0      RegisterAsBrowser=   0      RegisterAsDropTarget=   1      AutoArrange     =   0   'False      NoClientEdge    =   0   'False      AlignLeft       =   0   'False      NoWebView       =   0   'False      HideFileNames   =   0   'False      SingleClick     =   0   'False      SingleSelection =   0   'False      NoFolders       =   0   'False      Transparent     =   0   'False      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"      Location        =   "http:///"   End   Begin VB.CommandButton cmdOpenTable       Caption         =   "開啟表"      Height          =   390      Left            =   4170      TabIndex        =   7      Top             =   0      Width           =   1110   End   Begin VB.CommandButton cmdQuery       Caption         =   "查詢"      Height          =   390      Left            =   2895      TabIndex        =   6      Top             =   0      Width           =   1230   End   Begin VB.CommandButton cmdRefreshSQL       Caption         =   "重新整理SQL語句"      Height          =   390      Left            =   1260      TabIndex        =   5      Top             =   0      Width           =   1590   End   Begin VB.PictureBox picUpDown       Height          =   105      Left            =   3360      MousePointer    =   7  'Size N S      ScaleHeight     =   45      ScaleWidth      =   4875      TabIndex        =   4      Top             =   2850      Width           =   4935   End   Begin VB.TextBox txtSQL       BeginProperty Font          Name            =   "Fixedsys"         Size            =   12         Charset         =   134         Weight          =   400         Underline       =   0   'False         Italic          =   0   'False         Strikethrough   =   0   'False      EndProperty      Height          =   1935      Left            =   3525      MultiLine       =   -1  'True      ScrollBars      =   2  'Vertical      TabIndex        =   3      Top             =   750      Width           =   4815   End   Begin VB.CommandButton cmdConn       Caption         =   "串連資料庫"      Height          =   390      Left            =   0      TabIndex        =   2      Top             =   0      Width           =   1215   End   Begin VB.PictureBox picLeftRight       Height          =   5625      Left            =   3030      MousePointer    =   9  'Size W E      ScaleHeight     =   5565      ScaleWidth      =   30      TabIndex        =   1      Top             =   570      Width           =   90   End   Begin MSComctlLib.TreeView tvwTable       Height          =   6015      Left            =   -15      TabIndex        =   0      Top             =   405      Width           =   2895      _ExtentX        =   5106      _ExtentY        =   10610      _Version        =   393217      HideSelection   =   0   'False      Indentation     =   0      LabelEdit       =   1      LineStyle       =   1      Style           =   7      Checkboxes      =   -1  'True      Appearance      =   1   EndEndAttribute VB_Name = "frmViewData"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption ExplicitPrivate myConn As ADODB.ConnectionPrivate myRecordSet As ADODB.RecordsetPrivate strConn As StringPrivate bolDraging As BooleanPrivate lngLastPos As LongPrivate Sub SetControlSize()    On Error Resume Next    tvwTable.Width = picLeftRight.Left - tvwTable.Left    tvwTable.Height = Me.ScaleHeight - tvwTable.Top    picLeftRight.Top = tvwTable.Top    picLeftRight.Height = tvwTable.Height        txtSQL.Left = picLeftRight.Left + picLeftRight.Width    txtSQL.Top = tvwTable.Top    txtSQL.Width = Me.ScaleWidth - txtSQL.Left    txtSQL.Height = picUpDown.Top - txtSQL.Top        picUpDown.Left = txtSQL.Left    picUpDown.Width = txtSQL.Width        myGrid.Left = txtSQL.Left    myGrid.Top = picUpDown.Top + picUpDown.Height    myGrid.Width = txtSQL.Width    myGrid.Height = Me.ScaleHeight - myGrid.TopEnd SubPrivate Sub cmdConn_Click()    Dim dlg As New MSDASC.DataLinks    Dim myC As New ADODB.Connection    On Error GoTo ConnErr    dlg.hWnd = Me.hWnd    myC.ConnectionString = strConn    If dlg.PromptEdit(myC) = True Then        strConn = myC.ConnectionString        If myConn.State = 1 Then            myConn.Close        End If        myConn.ConnectionString = strConn        myConn.Open        RefreshView        txtSQL.Text = strConn    End If    Set myC = Nothing    Set dlg = Nothing    Exit SubConnErr:    MsgBox Err.Description, vbCritical, "系統錯誤"    Set myC = Nothing    Set dlg = NothingEnd SubPrivate Sub cmdCount_Click()    Dim strSQL  As String            If Not tvwTable.SelectedItem Is Nothing Then        If tvwTable.SelectedItem.Parent Is Nothing Then            strSQL = "select count(*) from " & tvwTable.SelectedItem.Text        Else            strSQL = "select count(*) from " & tvwTable.SelectedItem.Parent.Text        End If        txtSQL.Text = strSQL        cmdQuery_Click    End IfEnd SubPrivate Sub cmdMax_Click()    If Not tvwTable.SelectedItem Is Nothing Then        If Not tvwTable.SelectedItem.Parent Is Nothing Then            txtSQL.Text = "select max(" & tvwTable.SelectedItem.Text & ") From " & tvwTable.SelectedItem.Parent.Text            cmdQuery_Click        End If    End IfEnd SubPrivate Sub cmdMin_Click()    If Not tvwTable.SelectedItem Is Nothing Then        If Not tvwTable.SelectedItem.Parent Is Nothing Then            txtSQL.Text = "select min(" & tvwTable.SelectedItem.Text & ") From " & tvwTable.SelectedItem.Parent.Text            cmdQuery_Click        End If    End IfEnd SubPrivate Sub cmdOpenTable_Click()    Dim strSQL  As String    Dim strProvider As String    strProvider = VBA.Strings.LCase(myConn.Provider)        If Not tvwTable.SelectedItem Is Nothing Then        If tvwTable.SelectedItem.Parent Is Nothing Then            strSQL = tvwTable.SelectedItem.Text        Else            strSQL = tvwTable.SelectedItem.Parent.Text        End If        If VBA.Strings.InStr(1, strProvider, "oracle") > 0 Then            strSQL = "Select * From " & strSQL & " Where rownum<200"        Else            strSQL = "select  top 200 * From " & strSQL        End If        txtSQL.Text = strSQL        cmdQuery_Click    End IfEnd SubPrivate Sub cmdQuery_Click()    Dim myRS As New ADODB.Recordset    Dim strData As String    Dim intFH As Integer    Dim lCount As Long    Dim lRecordCount As Long    intFH = VBA.FreeFile()    On Error GoTo QueryErr    myRS.Open txtSQL.Text, myConn, adOpenStatic, adLockReadOnly, adCmdText    Open App.Path & "\temp.htm" For Output As #intFH    Print #intFH, "<html><head><title>查詢結果</title></head><style>TD {FONT-FAMILY: 宋體; FONT-SIZE: 9pt}</style><body topmargin='1' leftmargin='1' rightmargin='1' bottommargin='1' bgcolor='#c3c3c3'><table cellspacing='0' rules='all' bordercolor='#999999' border='1'  style='border-color:#CC0066; border-collapse:collapse;  ' bgcolor='#f1f1f1'>"    Print #intFH, "<tr style='background-color:#c2c2c2;'>"    Print #intFH, "<td><b>SEQ</b></td>"    For lCount = 0 To myRS.Fields.Count - 1        Print #intFH, "<td>" & myRS.Fields(lCount).Name & "</td>"    Next    lRecordCount = 0    Do Until myRS.EOF        Print #intFH, "<tr><td>" & lRecordCount & "</td>"        For lCount = 0 To myRS.Fields.Count - 1            If IsNull(myRS.Fields(lCount).Value) Then                strData = "&lt;NULL&gt;"            Else                strData = myRS.Fields(lCount).Value                If VBA.Strings.InStr(1, strData, "<") > 0 Then                    strData = VBA.Strings.Replace(strData, "<", "&lt;")                    strData = VBA.Strings.Replace(strData, ">", "&gt;")                End If            End If            Print #intFH, "    <td>" & strData & "</td>"        Next        Print #intFH, "</tr>"        myRS.MoveNext        lRecordCount = lRecordCount + 1    Loop        Print #intFH, "</table>"    Print #intFH, "共返回 " & lRecordCount & " 條記錄 ，" & myRS.Fields.Count & " 個欄目"    Print #intFH, "</body></html>"        Close #intFH    myGrid.Navigate App.Path & "\temp.htm"    Me.Caption = "共返回 " & myRS.RecordCount & " 條記錄"    myRS.Close    Set myRS = Nothing    Exit SubQueryErr:    VBA.FileSystem.Reset    Set myRS = Nothing    MsgBox Err.Description, vbCritical, "系統錯誤"    On Error GoTo 0End SubPrivate Sub cmdRefreshSQL_Click()    Dim TableNode As MSComctlLib.Node    Dim FieldNode As MSComctlLib.Node    Dim myNode As MSComctlLib.Node    Dim strSQL As String    Dim strTable As String    If tvwTable.Nodes.Count > 0 Then        For Each myNode In tvwTable.Nodes            If myNode.Checked = True And (Not myNode.Parent Is Nothing) Then                If strSQL = "" Then                    strSQL = "   " & myNode.Parent.Text & "." & myNode.Text                Else                    strSQL = strSQL & " ," & vbCrLf & "   " & myNode.Parent.Text & "." & myNode.Text                End If                If VBA.Strings.InStr(1, strTable, myNode.Parent.Text & ",") <= 0 Then                    strTable = strTable & vbCrLf & myNode.Parent.Text & ","                End If                            End If        Next        If strSQL <> "" Then            txtSQL.Text = "Select " & vbCrLf & strSQL & vbCrLf & " From " & VBA.Strings.Left(strTable, VBA.Strings.Len(strTable) - 1)        End If    End IfEnd SubPrivate Sub Form_Load()    myGrid.Navigate "about:blank"    bolDraging = False    picLeftRight.BorderStyle = 0    picUpDown.BorderStyle = 0    Set myConn = New ADODB.Connection    Set myRecordSet = New ADODB.Recordset    strConn = VBA.GetSetting(App.Title, Me.Name, "conn")    On Error GoTo LoadErr    If strConn <> "" Then        myConn.Open strConn        RefreshView    End If        Exit SubLoadErr:    MsgBox Err.Description, vbCritical, "系統錯誤"    On Error GoTo 0End SubPrivate Sub RefreshView()    Dim strProvider As String    Dim strSQL As String    Dim strTableName As String    Dim TableNode As MSComctlLib.Node    Dim FieldNode As MSComctlLib.Node        Dim myRS As New ADODB.Recordset    On Error GoTo RefreshErr        strProvider = VBA.Strings.LCase(myConn.Provider)    tvwTable.Visible = False    tvwTable.Nodes.Clear    tvwTable.Visible = True    Me.MousePointer = 11    Me.Refresh    If VBA.Strings.InStr(1, strProvider, "oracle") > 0 Then        strSQL = "Select TName,CName,coltype,width  From Col Order by TName,CName"    Else        strSQL = "select  sysobjects.name ,syscolumns.name  ,systypes.name ,syscolumns.length ,syscolumns.xtype from syscolumns,sysobjects,systypes where syscolumns.id=sysobjects.id and syscolumns.xtype=systypes.xtype and sysobjects.type='U' and systypes.name <>'_default_' and systypes.name<>'sysname' order by sysobjects.name,syscolumns.name"    End If    myRS.Open strSQL, myConn, adOpenStatic, adLockReadOnly, adCmdText        Do Until myRS.EOF        If strTableName <> myRS.Fields(0).Value Then            strTableName = myRS.Fields(0).Value            Set TableNode = tvwTable.Nodes.Add()            TableNode.Text = strTableName        End If        Set FieldNode = tvwTable.Nodes.Add(TableNode.Index, tvwChild)        FieldNode.Text = myRS.Fields(1).Value                myRS.MoveNext    Loop    myRS.Close    Set myRS = Nothing    Me.MousePointer = 0    Exit SubRefreshErr:    Set myRS = Nothing    Me.MousePointer = 0    On Error GoTo 0End Sub Private Sub Form_Resize()    If Me.WindowState <> 1 Then        SetControlSize    End IfEnd SubPrivate Sub Form_Unload(Cancel As Integer)    If myConn.ConnectionString <> "" Then        VBA.SaveSetting App.Title, Me.Name, "conn", myConn.ConnectionString    End If    If myConn.State = 1 Then        myConn.Close    End If    Set myConn = Nothing    Set myRecordSet = Nothing    End SubPrivate Sub picLeftRight_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)    bolDraging = True    lngLastPos = XEnd SubPrivate Sub picLeftRight_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)    If bolDraging = True Then        Dim lPos As Long        lPos = picLeftRight.Left + X - lngLastPos        If lPos < 1000 Then            lPos = 1000        End If        If lPos > Me.ScaleWidth - 1000 Then            lPos = Me.ScaleWidth - 1000        End If        picLeftRight.Left = lPos        SetControlSize    End IfEnd SubPrivate Sub picLeftRight_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)    bolDraging = FalseEnd Sub Private Sub picUpDown_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)    bolDraging = True    lngLastPos = YEnd SubPrivate Sub picUpDown_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)    If bolDraging = True Then        Dim lPos As Long        lPos = picUpDown.Top + Y - lngLastPos        If lPos < 1000 Then            lPos = 1000        End If        If lPos > Me.ScaleHeight - 1000 Then            lPos = Me.ScaleHeight - 1000        End If        picUpDown.Top = lPos        SetControlSize    End IfEnd SubPrivate Sub picUpDown_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)    bolDraging = FalseEnd SubPrivate Sub tvwTable_NodeCheck(ByVal Node As MSComctlLib.Node)    Dim myNode As MSComctlLib.Node    Dim bolCheck As Boolean    If Not Node Is Nothing Then        If Node.Parent Is Nothing Then            Set myNode = Node.Child            Do Until myNode Is Nothing                myNode.Checked = Node.Checked                Set myNode = myNode.Next            Loop        Else            bolCheck = False            Set myNode = Node.FirstSibling            Do Until myNode Is Nothing                If myNode.Checked = True Then                    bolCheck = True                    Exit Do                End If                Set myNode = myNode.Next            Loop            Node.Parent.Checked = bolCheck        End If    End IfEnd Sub