mdl.bas

这个是VB环境开发的,我也是转载的把原来的Access数据库改成了SQl Server数据库.希望大家可以借鉴

Attribute VB_Name = "Module1"
Public cn As New Connection, rs As New Recordset, Usrpass As String, UsrDepartment As String
Public UsrName  As String, Flg As Boolean, Compid, Baojin
Public RSF As New Recordset
Public Const ginfo = "提示信息"
'**************************************
Public sqlstr As String, rd As ADODB.Recordset

Public Sub BandDataToDataGrid(DatGrd As DataGrid, rr As ADODB.Recordset)
    Set rr = New ADODB.Recordset
    rr.Source = sqlstr
    rr.Open , cn, adOpenKeyset, adLockOptimistic
    Set DatGrd.DataSource = rr
End Sub


Public Sub LoadDataToCombo(Cmb As ComboBox)
    Set rs = New ADODB.Recordset
    rs.Source = sqlstr
    rs.Open , cn, adOpenKeyset, adLockOptimistic
    
    Do While Not rs.EOF
        Cmb.AddItem rs.Fields(0).Value
        rs.MoveNext
    Loop
    rs.Close: Set rs = Nothing
End Sub

Public Sub xlstomdb(Filename As String, adogrd As Adodc)
 On Error GoTo errl
Dim excel_app As Object
Dim excel_sheet As Object
Dim row As Integer
Dim strcol(7) As String
    Screen.MousePointer = vbHourglass
    DoEvents

    ' Create the Excel application.
    Set excel_app = CreateObject("Excel.Application")
   
    excel_app.Workbooks.Open Filename:=Filename

    ' Check for later versions.
    If Val(excel_app.Application.Version) >= 8 Then
        Set excel_sheet = excel_app.ActiveSheet
    Else
        Set excel_sheet = excel_app
    End If
    Dim iLine As Integer
    iLine = 1: row = 2
   Do
      For iLine = 1 To 5
          strcol(iLine - 1) = Trim$(excel_sheet.Cells(row, iLine))
                    
          If Len(strcol(iLine - 1)) = 0 Then Exit For
                          
          If iLine = 5 Then Exit For
      Next iLine
      If Len(strcol(0)) = 0 Or Len(strcol(1)) = 0 Then
        Exit Sub
        'Screen.MousePointer = vbDefault
      End If
      adogrd.Recordset.Filter = "元件名称='" & Trim(strcol(0)) & "' and 类型 = '" & Trim(strcol(1)) & "'"
      'adogrd.Recordset.Find "类型 = '" & Trim(strcol(1)) & "'"
      If adogrd.Recordset.EOF Or adogrd.Recordset.BOF Then
         adogrd.Recordset.Filter = ""
      If adogrd.Recordset.RecordCount > 0 Then
                    Idadd = adogrd.Recordset.RecordCount
                 Else
                    Idadd = 0
           End If
            adogrd.Recordset.AddNew
            adogrd.Recordset.Fields!ID = Idadd + 1
            adogrd.Recordset.Fields!元件名称 = strcol(0)
            adogrd.Recordset.Fields!所需量 = strcol(2)
            'adogrd.Recordset.Fields!说明 = adogrd.Recordset.Fields!说明 + ""strcol(3)
            adogrd.Recordset.Fields!说明 = strcol(3)
            adogrd.Recordset.Fields!类型 = strcol(1)
            adogrd.Recordset.Fields!单位 = strcol(4)
            adogrd.Recordset.UpdateBatch adAffectCurrent
      Else
            adogrd.Recordset.Fields!所需量 = strcol(2)
            adogrd.Recordset.UpdateBatch adAffectCurrent
      End If
      row = row + 1
  Loop
 
    excel_app.ActiveWorkbook.Close False

    ' Close Excel.
    excel_app.Quit
    Set excel_sheet = Nothing
    Set excel_app = Nothing

    Screen.MousePointer = vbDefault
    adogrd.Recordset.Filter = ""
    Exit Sub
errl:    MsgBox err.Description
End Sub

Public Sub Transfer()
Dim result As Integer
result = MsgBox("是否数据库备份完毕？如没有请先进行备份操作。", vbYesNo + vbDefaultButton2, ginfo)
If result = 7 Then Exit Sub
Dim rst As New ADODB.Recordset
Dim sqlstr As String
Dim STRre As String
rst.Open "select ID from iotbl", cn, adOpenKeyset, adLockOptimistic
rst.MoveLast
sqlstr = "insert into backup  select * from iotbl where ID <" & Str(rst.Fields(0))
STRre = gSqlExecute(sqlstr)
If STRre = "OK" Then
    sqlstr = "delete * from iotbl where ID<" & Str(rst.Fields(0))
    If gSqlExecute(sqlstr) = "OK" Then
        MsgBox "   数据整理成功！  ", , ginfo
    End If
    rst.Close
Else
       MsgBox "  数据整理成功！ ", , ginfo
End If
End Sub
Public Function gSqlExecute(strsql As String) As String
On Error GoTo err
Dim cmd As New ADODB.Command
If cn.State = 0 Then
  gSqlExecute = "连接数据库错误！"
  Exit Function
End If
Set cmd.ActiveConnection = cn
cmd.CommandText = strsql
cmd.Execute
gSqlExecute = "OK"

Exit Function
err:
gSqlExecute = err.Description
End Function