frmmain.frm

几个不错的VB例子

      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "Database Settings"
      Height          =   1095
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   12015
      Begin VB.CheckBox chkContinue 
         Caption         =   "Use Continuation"
         Height          =   255
         Left            =   8760
         TabIndex        =   46
         Top             =   360
         Width           =   1575
      End
      Begin VB.CheckBox chkPartial 
         Caption         =   "Partial Format"
         Height          =   255
         Left            =   10560
         TabIndex        =   45
         Top             =   360
         Width           =   1335
      End
      Begin VB.CommandButton cmdCall 
         Caption         =   "..."
         Height          =   300
         Left            =   11520
         TabIndex        =   32
         ToolTipText     =   "Build Connect Statement"
         Top             =   720
         Width           =   375
      End
      Begin VB.TextBox txtDBName 
         Height          =   285
         Left            =   6960
         TabIndex        =   25
         Text            =   "txtDBName"
         Top             =   360
         Width           =   1335
      End
      Begin VB.TextBox txtDB 
         Height          =   285
         Left            =   1560
         TabIndex        =   6
         Text            =   "txtDB"
         Top             =   720
         Width           =   9975
      End
      Begin VB.ComboBox cboDB 
         Height          =   315
         Left            =   1560
         TabIndex        =   4
         Text            =   "cboDB"
         Top             =   360
         Width           =   3495
      End
      Begin VB.Label Label2 
         Caption         =   "DB Variable Name :"
         Height          =   255
         Index           =   4
         Left            =   5400
         TabIndex        =   24
         Top             =   360
         Width           =   1455
      End
      Begin VB.Label Label1 
         Caption         =   "Connection String :"
         Height          =   255
         Index           =   1
         Left            =   120
         TabIndex        =   5
         Top             =   720
         Width           =   1455
      End
      Begin VB.Label Label1 
         Caption         =   "Database Name :"
         Height          =   255
         Index           =   0
         Left            =   120
         TabIndex        =   3
         Top             =   360
         Width           =   1335
      End
   End
   Begin RichTextLib.RichTextBox rtb 
      Height          =   4965
      Left            =   3000
      TabIndex        =   1
      Top             =   2640
      Width           =   9135
      _ExtentX        =   16113
      _ExtentY        =   8758
      _Version        =   393217
      ScrollBars      =   3
      TextRTF         =   $"frmMain.frx":0000
   End
   Begin VB.ListBox lstTables 
      Height          =   6300
      Left            =   120
      TabIndex        =   0
      Top             =   1320
      Width           =   2775
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private msTableName As String

Private Const miC_INSERT As Integer = 0
Private Const miC_DELETE As Integer = 1
Private Const miC_UPDATE As Integer = 2
Private Const miC_DIM As Integer = 3

Private Const miT_STRING_VAR    As Integer = 0
Private Const miT_SQL_CHECK     As Integer = 1
Private Const miT_TEXT_BOX      As Integer = 2
Private Const miT_SPACES        As Integer = 3
Private Const miT_RECORDSET     As Integer = 4
Private Const miT_PREFIX        As Integer = 5

Private msDBName(15) As String
Private msDBConnect(15) As String
Private miDBNameNum As Integer


Private Sub cboDB_Click()
If gbErrorHandSwitch Then On Error GoTo ErrHandler
    Dim i As Integer
    
    For i = 0 To 15
        If cboDB = msDBName(i) Then
            miDBNameNum = i
            txtDB = msDBConnect(i)
            Call SaveSetting("SQLS", "Settings", "DBNum", i)
            cmd(2) = True
            Exit Sub
        End If
    Next i

ErrExit:      Exit Sub
ErrHandler:   Call ErrorHandler(Name, 0, "cboDB_Click")
End Sub

Private Sub cmd_Click(Index As Integer)
If gbErrorHandSwitch Then On Error GoTo ErrHandler
    Dim i As Integer
    Dim rstTables As ADODB.Recordset
    Dim rstCols As ADODB.Recordset
    Dim sSql As String, sData As String, sDecl As String
    Dim sLeft As String, s As String
    Dim sView As String, sFunc1(3) As String, sFunc2(3) As String
    Dim iDType As Integer
    
    Const iB_BUILD = 0
    Const iB_EXIT = 1
    Const iB_CONNECT = 2
    Const iB_FORMAT = 3
    Const iB_COPY = 4
    Const iB_CLEAN = 5
    Const iB_HELP = 6
    Const iB_PASTE = 7
    Const iB_CHECK = 8
    Const iB_FIELDS = 9
    Const iB_ASSIGN = 10
    Const iB_PRINT = 11

    Const i_TEXT = 0
    Const i_DATE = 1
    Const i_NUMERIC = 2
    Const i_ELSE = 3
    

    Select Case Index
    Case iB_CLEAN:      rtb.Text = ""
    Case iB_HELP:       frmHelp.Show
    Case iB_PRINT
        cd.Flags = cdlPDReturnDC + cdlPDNoPageNums
        If rtb.SelLength = 0 Then
           cd.Flags = cd.Flags + cdlPDAllPages
        Else
           cd.Flags = cd.Flags + cdlPDSelection
        End If
        cd.ShowPrinter
        rtb.SelPrint cd.hDC
        
    
    Case iB_ASSIGN
        MousePointer = vbHourglass
        
        
        If msTableName = "" Then
            MsgBox "Please select Table and try again."
            MousePointer = vbDefault
            Exit Sub
        End If
        
        rtb.Text = ""
        sView = ""
        Set rstCols = gdbSQLQ.OpenSchema(adSchemaColumns)
        
        sSql = "' == " & UCase(msTableName) & " == " & vbCrLf & vbCrLf
        sSql = sSql & "sSql = ""select * from " & UCase(msTableName) & "  where """ & vbCrLf
        sSql = sSql & "Set R_S_T = SQLOpenrecordsetADO(" & txtDBName & ",sSql)" & vbCrLf & vbCrLf
        
        Do Until rstCols.EOF
            If rstCols.Fields(2) = msTableName Then
                sSql = sSql & "T_X_T(m_i_T_" & UCase(rstCols.Fields(3)) & ")  = R_S_T!" & rstCols.Fields(3) & vbCrLf
            End If
            rstCols.MoveNext
        Loop
        sView = sSql
        
        If chkFormat(miT_SPACES) Then sView = Replace(sView, "sSql = ", Space(Val(txtFormat(miT_SPACES))) & " sSql = ")
        If chkFormat(miT_SPACES) Then sView = Replace(sView, "T_X_T", Space(Val(txtFormat(miT_SPACES))) & " T_X_T")
        If chkFormat(miT_SPACES) Then sView = Replace(sView, "Set R_S_T = ", Space(Val(txtFormat(miT_SPACES))) & " Set R_S_T = ")
        If chkFormat(miT_TEXT_BOX) Then sView = Replace(sView, "T_X_T", txtFormat(miT_TEXT_BOX))
        If chkFormat(miT_RECORDSET) Then sView = Replace(sView, "R_S_T", txtFormat(miT_RECORDSET))
        If chkFormat(miT_PREFIX) Then sView = Replace(sView, "m_i_T_", txtFormat(miT_PREFIX))
        If chkFormat(miT_STRING_VAR) Then sView = Replace(sView, "sSql", txtFormat(miT_STRING_VAR))
        
        rtb.Text = sView
        
    Case iB_FIELDS
        MousePointer = vbHourglass
        
        
        If msTableName = "" Then
            MsgBox "Please select Table and try again."
            MousePointer = vbDefault
            Exit Sub
        End If
        
        rtb.Text = ""
        sView = ""
        Set rstCols = gdbSQLQ.OpenSchema(adSchemaColumns)
        
        sSql = " == " & UCase(msTableName) & " == " & vbCrLf & vbCrLf
        
        Do Until rstCols.EOF
            If rstCols.Fields(2) = msTableName Then
                sSql = sSql & rstCols.Fields(3) & vbCrLf
            End If
            rstCols.MoveNext
        Loop
        
        sView = sSql
        
        rtb.Text = sSql
    
    Case iB_EXIT:
        Unload Me
        End
        
    Case iB_COPY:
        With rtb
            .SetFocus
            .SelStart = 0
            .SelLength = Len(.Text)
            Clipboard.SetText (.SelText)
        End With
    
    Case iB_PASTE:
        rtb.Text = Clipboard.GetText
        
    Case iB_CHECK:
        sView = rtb.Text
        
        If InStr(LCase(sView), "select ") = 0 Then
            MsgBox "It's not Select Query. Put the right one in and try again."
            Exit Sub
        End If
        
        sView = Replace(sView, Chr(13), "")
        sView = Replace(sView, Chr(10), "")
        sView = Replace(sView, "dbo.", "")
        sView = Replace(sView, "from ", " FROM ")
        sView = Replace(sView, "From ", " FROM ")
        sView = Replace(sView, "FROM ", " FROM ")
        
        rtb.Text = sView
        Clipboard.SetText sView
    
    Case iB_FORMAT:
        sView = rtb.Text
        
        If InStr(LCase(sView), "select ") = 0 Then
            MsgBox "It's not Select Query. Put the right one in and try again."
            Exit Sub
        End If
        
        sView = Replace(sView, Chr(13), "")
        sView = Replace(sView, Chr(10), "")
        sView = Replace(sView, "dbo.", "")
        sView = Replace(sView, "sSql = sSql & ", "")
        sView = Replace(sView, "sSql = ", "")
        If chkFormat(miT_STRING_VAR) Then sView = Replace(sView, txtFormat(miT_STRING_VAR) & " = " & txtFormat(miT_STRING_VAR) & " & ", "")
        If chkFormat(miT_STRING_VAR) Then sView = Replace(sView, txtFormat(miT_STRING_VAR) & " = ", "")
        
        sView = SQLFormat(sView)
        If chkFormat(miT_SPACES) Then sView = Replace(sView, "sSql = ", Space(Val(txtFormat(miT_SPACES))) & "sSql = ")
        If chkContinue <> 0 And chkFormat(miT_SPACES) Then sView = Replace(sView, "& """, Space(Val(txtFormat(miT_SPACES))) & "& """)
        sSql = ""
        sSql = sSql & sView
        
        If chkFormat(miT_STRING_VAR) Then sView = Replace(sView, "sSql", txtFormat(miT_STRING_VAR))
        
        rtb.Text = sView
        Clipboard.SetText sView
        
    Case iB_BUILD
        MousePointer = vbHourglass
        
        
        If msTableName = "" Then
            MsgBox "Please select Table and try again."
            MousePointer = vbDefault
            Exit Sub
        End If
        
        rtb.Text = ""
        sView = ""
        Set rstCols = gdbSQLQ.OpenSchema(adSchemaColumns)
        i = 0
        
        sFunc2(i_TEXT) = ")"
        sFunc2(i_DATE) = ")"
        sFunc2(i_NUMERIC) = ")"
        sFunc2(i_ELSE) = ""
        
        If miT_SQL_CHECK Then
            sFunc1(i_TEXT) = txtFormat(miT_SQL_CHECK) & "("
        Else
            sFunc1(i_TEXT) = "SQLCheck("
        End If
        sFunc1(i_DATE) = "AMDateTime("
        sFunc1(i_NUMERIC) = "Val("
        sFunc1(i_ELSE) = ""
        
        ' Creates Insert
            sDecl = ""
            sData = ""
            sSql = vbCrLf
            sSql = sSql & "' INSERT STATEMENT"
            sSql = sSql & vbCrLf
            sSql = sSql & "sSql = ""insert into " & msTableName & " (""" & vbCrLf
            
            Do Until rstCols.EOF
                If rstCols.Fields(2) = msTableName Then
                    sDecl = sDecl & "Private const m_i_T_" & UCase(rstCols.Fields(3)) & " = " & CStr(i) & vbCrLf
                    sSql = sSql & "sSql = sSql & """ & rstCols.Fields(3) & ",""" & vbCrLf
                    iDType = DBDataType(rstCols.Fields(11))
                    sData = sData & "sSql = sSql & " & sFunc1(iDType) & "T_X_T(m_i_T_" & UCase(rstCols.Fields(3)) & ")" & sFunc2(iDType) & " & "",""" & vbCrLf
                    i = i + 1