connect.frm

《VB6数据库开发指南》所有的例程的源码

VERSION 5.00
Begin VB.Form frmODBC 
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Chapter 6.4 Example"
   ClientHeight    =   4380
   ClientLeft      =   1080
   ClientTop       =   1500
   ClientWidth     =   4590
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4380
   ScaleWidth      =   4590
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton cmdCopyConnect 
      Caption         =   "Cop&y Connect String"
      Enabled         =   0   'False
      Height          =   495
      Left            =   2430
      TabIndex        =   4
      Top             =   1620
      Width           =   2055
   End
   Begin VB.CommandButton cmdGetConnect 
      Caption         =   "&Get Connect String"
      Enabled         =   0   'False
      Height          =   495
      Left            =   2430
      TabIndex        =   3
      Top             =   990
      Width           =   2055
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "&Quit"
      Height          =   495
      Left            =   3390
      TabIndex        =   5
      Top             =   3780
      Width           =   1095
   End
   Begin VB.TextBox txtConnect 
      BackColor       =   &H00C0C0C0&
      Height          =   1215
      Left            =   90
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   7
      TabStop         =   0   'False
      Top             =   2430
      Width           =   4395
   End
   Begin VB.CommandButton cmdConnect 
      Caption         =   "&Connect to Data Source"
      Height          =   495
      Left            =   2460
      TabIndex        =   2
      Top             =   360
      Width           =   2055
   End
   Begin VB.ListBox lstTables 
      Height          =   1815
      Left            =   90
      Sorted          =   -1  'True
      TabIndex        =   1
      Top             =   330
      Width           =   2175
   End
   Begin VB.Label lblConnect 
      BackColor       =   &H00C0C0C0&
      Caption         =   "Connect String:"
      Height          =   255
      Index           =   1
      Left            =   90
      TabIndex        =   6
      Top             =   2190
      Width           =   1215
   End
   Begin VB.Label lblConnect 
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Tables Available:"
      Height          =   255
      Index           =   0
      Left            =   90
      TabIndex        =   0
      Top             =   90
      Width           =   2175
   End
End
Attribute VB_Name = "frmODBC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'Module level globals to hold connection info
Dim dbfTemp As Database, recTemp As Recordset

Private Sub cmdConnect_Click()
    'Connect to a data source and populate lstTables
    Dim I As Integer
    Dim strConnect As String
    Dim tbfTemp As TableDef
    
    Screen.MousePointer = vbHourglass
    lstTables.Clear
    
    On Error GoTo ErrHandler
        Set dbfTemp = OpenDatabase("", False, False, "ODBC;")
    On Error GoTo 0
    
    For Each tbfTemp In dbfTemp.TableDefs
        lstTables.AddItem tbfTemp.Name
    Next
       
    Screen.MousePointer = vbDefault
    
    If lstTables.ListCount Then
        cmdGetConnect.Enabled = True
    Else
        MsgBox "No are tables available. Please connect to another data source."
    End If
        
Exit Sub
    
ErrHandler:
    Screen.MousePointer = vbDefault
    Select Case Err.Number
        Case 3423
            'This data source can't be attached, (or the
            'user clicked Cancel, so use ODBC API
            APIConnect
        Case 3059
            'The user clicked on Cancel
            Exit Sub
        Case Else
            'The error is something else, so send it back to
            'the VB exception handler
            MsgBox Err.Number, vbExclamation
    End Select
End Sub

Private Sub cmdCopyConnect_Click()
    'Select the text in txtConnect
    With txtConnect
        .SetFocus: .SelStart = 0: .SelLength = Len(txtConnect.text)
    End With
        
    ' Copy selected text to Clipboard.
    Clipboard.SetText Screen.ActiveControl.SelText
End Sub

Private Sub cmdGetConnect_Click()
    Screen.MousePointer = vbHourglass
    txtConnect.text = ""
    
    If Len(lstTables.text) Then
        Set recTemp = dbfTemp.OpenRecordset(lstTables.text)
        txtConnect.text = AddSpaces(dbfTemp.Connect)
    Else
        MsgBox "Please select a table first."
    End If
    
    cmdCopyConnect.Enabled = True
    Screen.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
    'Log on to an ODBC data source
    'First, allocate ODBC memory and get handles
    Dim intResult As Integer
    
    'Allocate the ODBC environment handle
    If SQLAllocEnv(glng_hEnv) <> SQL_SUCCESS Then End
    
    intResult = SQLAllocConnect(glng_hEnv, glng_hDbc)
    If intResult <> SQL_SUCCESS Then
        intResult = frmODBCErrors.ODBCError("Dbc", glng_hEnv, glng_hDbc, 0, intResult, "Error allocating connection handle.")
        End
    End If

    frmODBC.Show
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim intResult As Integer
    
    intResult = ODBCDisconnectDS(glng_hEnv, glng_hDbc, glng_hStmt)
    intResult = SQLFreeEnv(glng_hEnv)
End Sub

Private Sub cmdQuit_Click()
    End
End Sub

Private Sub lstTables_DblClick()
    cmdGetConnect_Click
End Sub

Sub APIConnect()
    'Can't connect through VB, so go direct
    Dim intResult As Integer
    Dim strConnectIn As String
    Dim strConnectOut As String * SQL_MAX_OPTION_STRING_LENGTH
    Dim intOutCount As Integer
    
    strConnectIn = ""
    
    intResult = SQLDriverConnect(glng_hDbc, Me.hWnd, strConnectIn, Len(strConnectIn), strConnectOut, Len(strConnectOut), intOutCount, SQL_DRIVER_PROMPT)
    If intResult <> SQL_SUCCESS Then
        intResult = frmODBCErrors.ODBCError("Dbc", glng_hEnv, glng_hDbc, 0, intResult, "Problem with call to SQLDriverConnect.")
        Exit Sub
    End If
    txtConnect.text = AddSpaces(strConnectOut)
    
    'Free the connection, but not the handle
    intResult = SQLDisconnect(glng_hDbc)
    If intResult <> SQL_SUCCESS Then
        intResult = frmODBCErrors.ODBCError("Dbc", glng_hEnv, glng_hDbc, 0, intResult, "Problem with call to SQLDriverConnect.")
    End If

    cmdCopyConnect.Enabled = True
End Sub

Function AddSpaces(strC As String)
    Dim I As Integer
    Dim strNewStr As String, strNextChar As String
    
    For I = 1 To Len(strC)
        strNextChar = Mid$(strC, I, 1)
        If strNextChar = ";" Then
            strNewStr = strNewStr & strNextChar & " "
        Else
            strNewStr = strNewStr & strNextChar
        End If
    Next
    AddSpaces = strNewStr
End Function