import.ctl

这是一个可以实现从数据库外部直接转入任何表的任何数据的控件的源代码

                SS_Yb = " 1=2 "
            End If
            If SS_TB.State = 1 Then Set SS_TB = Nothing
            SS_TB.Open "select top 1 * from (" & Im_TbStr & ") as tem where " & SS_Yb, Im_Connection, adOpenForwardOnly, adLockReadOnly
            If Not SS_TB.EOF Then
                SS_Col = SS_Col + 1
                GoTo Nexts
            End If
        End If
        S_Mb.AddNew
        For SS_i = 1 To Lis_ImZdpp.ListItems.Count
            S_Mb(Lis_ImZdpp.ListItems(SS_i).SubItems(1)) = S_Yb(Lis_ImZdpp.ListItems(SS_i).Text)
        Next SS_i
        S_Mb.update
Nexts:
        S_Yb.MoveNext
    Wend
    PBar.Value = 0
    MsgBox "导入完成，共处理数据" & S_Yb.RecordCount & "条，其中成功导入" & S_Yb.RecordCount - SS_Col & "条。", 48, "导入完成"
    Exit Sub
sk:
    MsgBox Err.Description, 16, "警告"
    'Resume Next
    Exit Sub
End Sub

Private Sub cmd_ImQuit_Click()
     RaiseEvent EndClick
End Sub

Private Sub cmdRep_Click()
    On Error GoTo sk
    Dim SS_Yb, SS_Mb
    Dim SS_Col
    Dim SS_Col1
    PBar.Max = S_Yb.RecordCount + 1
    PBar.Value = 0
    SS_Col = 0
    If Not S_Yb.EOF Or Not S_Yb.BOF Then
        S_Yb.MoveFirst
    End If
    While Not S_Yb.EOF
        PBar.Value = PBar.Value + 1
        SS_Yb = ""
        SS_Mb = ""
        For SS_i = 1 To Lis_ImZdpp.ListItems.Count
            If Lis_ImZdpp.ListItems(SS_i).Checked = True Then
                
                SS_Yb = SS_Yb & " and " & Lis_ImZdpp.ListItems(SS_i).SubItems(1) & "='" & S_Yb(Lis_ImZdpp.ListItems(SS_i).Text) & "'"
            Else
                SS_Mb = SS_Mb & "," & Lis_ImZdpp.ListItems(SS_i).SubItems(1) & "='" & S_Yb(Lis_ImZdpp.ListItems(SS_i).Text) & "'"
            End If
        Next SS_i
        If SS_Yb <> "" Then
            SS_Yb = Mid(SS_Yb, 5)
        Else
            MsgBox "必须选择至少一个标识字段", 16, "警告"
            Exit Sub
        End If
        If SS_Mb <> "" Then
            SS_Mb = Mid(SS_Mb, 2)
        Else
            MsgBox "必须选择至少一个导入字段", 16, "警告"
            Exit Sub
        End If
        'If S_Mb.State = 1 Then Set S_Mb = Nothing
        Im_Connection.Execute "update " & txt_ImYbm.Text & " set " & SS_Mb & " where " & SS_Yb, SS_Col1 ', Im_Connection, adOpenDynamic, adLockBatchOptimistic
        SS_Col = SS_Col + SS_Col1
        S_Yb.MoveNext
    Wend
    PBar.Value = 0
    MsgBox "导入完成，共处理数据" & S_Yb.RecordCount & "条，其中成功进行" & SS_Col & "次处理。", 48, "导入完成"
    Exit Sub
sk:
    MsgBox Err.Description, 16, "警告"
    Exit Sub
End Sub

Private Sub OptIn_Click()
    'txt_ImMbbm.Clear
    cmd_Ybm.Enabled = False
    If Im_DBType = 0 Then
        Im_DBType = Val(InputBox("请先设定您要导入源库的类型，1表示为ACCESS数据库，2表示SQL＿SERVER数据库", "导入提示", 1))
        If Im_DBType <> 1 And Im_DBType <> 2 Then
            MsgBox "您设定的类型不存在，只有1,2两种", 16, "导入"
            Exit Sub
        End If
    End If
    If S_Mb.State = 1 Then Set S_Mb = Nothing
    txt_ImMbbm.Clear
    
    'Lis_ImZdpp.ListItems.Clear
    cmdRef_Click
    Lis_ImMbbzd.ListItems.Clear
    If Im_DBType = ToSqlserver Then
        S_Mb.Open "select name from sysobjects where (type='V' or type='U') and status>0 order by name", Im_Connection, adOpenForwardOnly, adLockReadOnly
        While Not S_Mb.EOF
            txt_ImMbbm.AddItem S_Mb("name").Value & ""
            S_Mb.MoveNext
        Wend
    Else
        S_Mb.Open "select name from msysobjects where (type=1 and flags=0) or type=6 or type=5 order by name", Im_Connection, adOpenForwardOnly, adLockReadOnly
        While Not S_Mb.EOF
            txt_ImMbbm.AddItem S_Mb("name").Value & ""
            S_Mb.MoveNext
        Wend
    End If
    
End Sub
Private Sub cmdAotu_Click()
    Dim SS_i
    Dim ss_j
    For SS_i = lis_ImYbzd.ListItems.Count To 1 Step -1
        lis_ImYbzd.ListItems(SS_i).Selected = True
        For ss_j = Lis_ImMbbzd.ListItems.Count To 1 Step -1
            If UCase(lis_ImYbzd.ListItems(SS_i).Text) = UCase(Lis_ImMbbzd.ListItems(ss_j).Text) Then
                Lis_ImMbbzd.ListItems(ss_j).Selected = True
                Lis_ImMbbzd_DblClick
                Exit For
            End If
        Next ss_j
    Next SS_i
End Sub
Private Sub cmdRef_Click()
    Dim SS_i
    For SS_i = Lis_ImZdpp.ListItems.Count To 1 Step -1
        Lis_ImZdpp.ListItems(SS_i).Selected = True
        Lis_ImZdpp_DblClick
    Next SS_i
End Sub
Private Sub Lis_ImZdpp_DblClick()
    Dim SS_Item As ListItem
    If Lis_ImZdpp.SelectedItem Is Nothing Then
        Exit Sub
    End If
    Lis_ImMbbzd.ListItems.add , , Lis_ImZdpp.SelectedItem.Text
    lis_ImYbzd.ListItems.add , , Lis_ImZdpp.SelectedItem.SubItems(1)
    Lis_ImZdpp.ListItems.Remove Lis_ImZdpp.SelectedItem.Index
    
End Sub

Private Sub OptOut_Click()
    txt_ImMbbm.Clear
    'Lis_ImZdpp.ListItems.Clear
    cmdRef_Click
    Lis_ImMbbzd.ListItems.Clear
    cmd_Ybm.Enabled = True
End Sub

Private Sub Lis_ImMbbzd_DblClick()
    On Error GoTo Err_s
    Dim SS_Item As ListItem
    If Lis_ImMbbzd.SelectedItem Is Nothing Or lis_ImYbzd.SelectedItem Is Nothing Then
        Exit Sub
    End If
    Set SS_Item = Lis_ImZdpp.ListItems.add(, , Lis_ImMbbzd.SelectedItem.Text)
    SS_Item.SubItems(1) = lis_ImYbzd.SelectedItem.Text
    Lis_ImMbbzd.ListItems.Remove Lis_ImMbbzd.SelectedItem.Index
    lis_ImYbzd.ListItems.Remove lis_ImYbzd.SelectedItem.Index
    Exit Sub
Err_s:
    YN = MsgBox("错误警告:" & Err.Description & "在frmim.lis_immbbzd_dblclick中,是否继续?", 36)
    If YN = 6 Then
       Resume Next
    Else
        ProBar.Value = 0
       Exit Sub
    End If

End Sub

Private Sub txt_ImMbbm_Click()
    cmdRef_Click
    If OptIn.Value = True Then
        If Im_Conn.State = 1 Then Set Im_Conn = Nothing
        Im_Conn = Im_Connection.ConnectionString
        Im_Conn.Open
        OpenMbb Im_Conn, txt_ImMbbm.Text
    Else
        OpenMbb Im_Conn, Cd.FileTitle
    End If
    

End Sub
Sub OpenMbb(ByVal S_Im_Conn As Connection, ByVal S_TBName As String)
    Dim SS_i
    If S_Yb.State = 1 Then Set S_Yb = Nothing
    S_Yb.CursorLocation = adUseClient
    S_Yb.Open "select * from " & S_TBName, S_Im_Conn, adOpenForwardOnly, adLockReadOnly
    Lis_ImMbbzd.ListItems.Clear
    For SS_i = 0 To S_Yb.Fields.Count - 1
        Lis_ImMbbzd.ListItems.add , , S_Yb(SS_i).Name
    Next SS_i

End Sub

Public Sub ImAera(ByVal Sel_ImArea As Im_AreaType)
Attribute ImAera.VB_Description = "用户可在此处设定导入范围"
    Select Case Sel_ImArea
        Case 1
            OptOut.Visible = True
            OptIn.Visible = False
            cmd_Ybm.Enabled = True
        Case 2
            OptOut.Visible = False
            OptIn.Visible = True
            cmd_Ybm.Enabled = False
        Case 3
            cmd_Ybm.Enabled = True
            OptOut.Visible = True
            OptIn.Visible = True
    End Select
End Sub
Public Property Let GetImRecordSet(ByVal vNewValue As Recordset)
    On Error GoTo sk
    Dim SS_i
    Dim SS_p
    Set Im_Connection = vNewValue.ActiveConnection
    Im_TbStr = vNewValue.ActiveCommand.CommandText
    lis_ImYbzd.ListItems.Clear
    For SS_i = 0 To vNewValue.Fields.Count - 1
        lis_ImYbzd.ListItems.add , , vNewValue.Fields(SS_i).Name
    Next SS_i
    SS_p = Split(LCase(Im_TbStr), "from")
    SS_p = Split(Trim(SS_p(1)), " ")
    txt_ImYbm.Text = SS_p(0)
    Exit Property
sk:
    MsgBox Err.Description, 16, "警告"
    Resume Next
End Property

Private Sub cmd_Ybm_Click()
On Error GoTo Err_s
    Cd.FileName = ""
    Cd.Filter = "Dbase III(*.dbf)|*.dbf"
    Cd.ShowOpen
    If Dir(Cd.FileName) = "" Or Cd.FileName = "" Then
        Exit Sub
    End If
    If Im_Conn.State = 1 Then Set Im_Conn = Nothing
    Im_Conn.Open "Provider=MSDASQL.1;Persist Security Info=False;DefaultDir=" & Replace(Cd.FileName, Cd.FileTitle, "") & ";DRIVER=Microsoft dBase Driver (*.dbf);FIL=dBase III;"
    cmdRef_Click
    Lis_ImMbbzd.ListItems.Clear
    txt_ImMbbm.Clear
    txt_ImMbbm.AddItem Cd.FileName
    txt_ImMbbm.ListIndex = 0
    Exit Sub
Err_s:
    YN = MsgBox("错误警告:" & Err.Description & "在frmim.cmd_ybm_click中,是否继续?", 36)
    If YN = 6 Then
       Resume Next
    Else
        ProBar.Value = 0
       Exit Sub
    End If

End Sub