完整的代码

来源：互联网发布：e。target js 编辑：程序博客网时间：2024/04/30 02:24

Option Explicit

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
'定义变量来记字段变量
Dim sm, yz, ym, ISBN, fl, txm, zz, jydx, cbs, cfdd, ztq, bz, ptjljz, ISSN, kb As String
'定义书名,语种,译名,ISBN,分类,条形码,作者,借阅对象,出版社,存放地点,主题题,备注,配套资料介质,ISSN,,开本
Dim cbrq As String
'定义出版日期
Dim dj, ys, ptjlsl, kq, sl As Integer
'定义单价,页数,配套资料数量,刊期,数量
Dim addtshad, addqkhad As Boolean '定义已按“添加”按钮addtshad,addqkhad

'涮新期刊记录
Private Sub cmdqkrefresh_Click()
'只有多用户应用程序需要
On Error GoTo cmdqkrefresherr
qikan.Refresh
Exit Sub
cmdqkrefresherr:
MsgBox Err.Description
End Sub

'更新图书记录
Private Sub cmdtsupdate_Click()
On Error GoTo cmdtsupdateerr
    If Text1.Text = "" Then
        MsgBox "你还没有按“添加”按钮？"
        Exit Sub
    End If
    sl = Val(Text13.Text)
    If sl = 0 Or sl = 1 Then
        'tushu.Recordset.Fields("语种") = DataCombo1.BoundText
        'tushu.Recordset.Fields("书号") = Text1.Text
        tushu.Recordset.Fields("配套资料ID") = "pt" & Text1.Text
        tushu.Recordset.UpdateBatch adAffectAll
        Dim lgNum As Long
        lgNum = tushu.Recordset.AbsolutePosition
        tushu.Refresh
        tushu.Recordset.AbsolutePosition = lgNum
    Else
    '批量输入图书新书
        Dim i As Integer
        Dim strtxt As String
        Dim shtxt As String
        strtxt = Trim(Left$(Text1.Text, Len(Text1.Text) - 3))
        sm = Trim(Text2.Text)
        yz = DataCombo1.BoundText
        ym = Trim(Text3.Text)
        ISBN = Trim(Text4.Text)
        fl = DataCombo2.BoundText
        txm = Text5.Text
        zz = Text6.Text
        jydx = DataCombo3.BoundText
        cbs = Text7.Text
        If Text8.Text <> "" Then
            cbrq = Text8.Text
        End If
        cfdd = DataCombo4.BoundText
        ztq = Text9.Text
        bz = Text10.Text
        If Text11.Text <> "" Then
            dj = Text11.Text
        Else
            dj = Null
        End If
        If Text12.Text <> "" Then
            ys = Text12.Text
        Else
            ys = Null
        End If
        ptjljz = DataCombo5.BoundText
        If ptjljz <> "" Then
            ptjlsl = Text14.Text
        Else
            ptjlsl = Null
        End If
        For i = 1 To sl
            Select Case i
                Case Is < 10
                    shtxt = strtxt & "00" & i
                Case Is < 100
                    shtxt = strtxt & "0" & i
                Case Else
                    shtxt = strtxt
            End Select
            tushu.Recordset.Fields("书号") = shtxt
            tushu.Recordset.Fields("书名") = sm
            tushu.Recordset.Fields("语种") = yz
            tushu.Recordset.Fields("译名") = ym
            tushu.Recordset.Fields("ISBN") = ISBN
            tushu.Recordset.Fields("分类") = fl
            tushu.Recordset.Fields("条形码") = txm
            tushu.Recordset.Fields("作者") = zz
            tushu.Recordset.Fields("借阅对象") = jydx
            tushu.Recordset.Fields("出版社") = cbs
            If cbrq <> "" Then
                tushu.Recordset.Fields("出版日期") = cbrq
            End If
            tushu.Recordset.Fields("存放地点") = cfdd
            tushu.Recordset.Fields("主题词") = ztq
            tushu.Recordset.Fields("备注") = bz
            tushu.Recordset.Fields("单价") = dj
            tushu.Recordset.Fields("页数") = ys
            tushu.Recordset.Fields("配套资料ID") = "pt" & shtxt
            tushu.Recordset.Fields("配套资料介质") = ptjljz
            tushu.Recordset.Fields("配套资料数量") = ptjlsl
            tushu.Recordset.UpdateBatch adAffectAll
            If i < sl Then
                tushu.Recordset.AddNew
            End If
        Next
        lgNum = tushu.Recordset.AbsolutePosition
        tushu.Refresh
        tushu.Recordset.AbsolutePosition = lgNum
    End If
    addtshad = False
    Exit Sub
cmdtsupdateerr:
MsgBox Err.Description
End Sub

'更新期刊记录
Private Sub cmdqkupdate_Click()
On Error GoTo cmdqkupdateerr
    If Text15.Text = "" Then
        MsgBox "你还没有按“添加”按钮？"
        Exit Sub
    End If
    sl = Val(Text27.Text)
    If sl = 0 Or sl = 1 Then
        'tushu.Recordset.Fields("语种") = DataCombo1.BoundText
        'tushu.Recordset.Fields("书号") = Text1.Text
        qikan.Recordset.Fields("配套资料ID") = "pt" & Text1.Text
        qikan.Recordset.UpdateBatch adAffectAll
        Dim lgNum As Long
        lgNum = qikan.Recordset.AbsolutePosition
        qikan.Refresh
        qikan.Recordset.AbsolutePosition = lgNum
    Else
    '批量输入期刊新书
        Dim i As Integer
        Dim strtxt As String
        Dim shtxt As String
        strtxt = Trim(Left$(Text1.Text, Len(Text15.Text) - 3))
        sm = Text16.Text
        yz = DataCombo6.BoundText
        ym = Text17.Text
        ISSN = Text18.Text
        fl = DataCombo7.BoundText
        txm = Text19.Text
        If Text20.Text <> "" Then
            kq = Text20.Text
        Else
            kq = Null
        End If
        jydx = DataCombo8.BoundText
        cbs = Text21.Text
        If Text22.Text <> "" Then
            cbrq = Text22.Text
        End If
        cfdd = DataCombo9.BoundText
        kb = Combo1.Text
        bz = Text24.Text
        If Text25.Text <> "" Then
            dj = Text25.Text
        Else
            dj = Null
        End If
        If Text26.Text <> "" Then
            ys = Text26.Text
        Else
            ys = Null
        End If
        ptjljz = DataCombo10.BoundText
        If Text28.Text <> "" Then
            ptjlsl = Text28.Text
        Else
            ptjlsl = Null
        End If
        For i = 1 To sl
            Select Case i
                Case Is < 10
                    shtxt = strtxt & "00" & i
                Case Is < 100
                    shtxt = strtxt & "0" & i
                Case Else
                    shtxt = strtxt
            End Select
            qikan.Recordset.Fields("书号") = shtxt
            qikan.Recordset.Fields("书名") = sm
            qikan.Recordset.Fields("语种") = yz
            qikan.Recordset.Fields("译名") = ym
            qikan.Recordset.Fields("ISSN") = ISSN
            qikan.Recordset.Fields("分类") = fl
            qikan.Recordset.Fields("条形码") = txm
            qikan.Recordset.Fields("刊期") = kq
            qikan.Recordset.Fields("借阅对象") = jydx
            qikan.Recordset.Fields("出版社") = cbs
            If cbrq <> "" Then
                qikan.Recordset.Fields("出版日期") = cbrq
            End If
            qikan.Recordset.Fields("存放地点") = cfdd
            qikan.Recordset.Fields("开本") = kb
            qikan.Recordset.Fields("备注") = bz
            qikan.Recordset.Fields("单价") = dj
            qikan.Recordset.Fields("页数") = ys
            qikan.Recordset.Fields("配套资料ID") = "pt" & shtxt
            qikan.Recordset.Fields("配套资料介质") = ptjljz
            qikan.Recordset.Fields("配套资料数量") = ptjlsl
            qikan.Recordset.UpdateBatch adAffectAll
            If i < sl Then
                qikan.Recordset.AddNew
            End If
        Next
        lgNum = qikan.Recordset.AbsolutePosition
        qikan.Refresh
        qikan.Recordset.AbsolutePosition = lgNum
    End If
    addqkhad = False
    Exit Sub
cmdqkupdateerr:
MsgBox Err.Description
End Sub

'删除图书记录
Private Sub cmdtsdel_Click()
Dim lgNum As Long
On Error GoTo cmdtsdelerr
    Dim nYN As Byte
     nYN = MsgBox("您正准备删除当前记录。" & Chr(13) & Chr(13) & _
        "假如您单击“是”，您将不能撤消这个删除操作。" & Chr(13) & _
        "您确认删除这条记录吗?", vbExclamation + vbYesNo)
    If nYN = vbYes Then
      lgNum = tushu.Recordset.AbsolutePosition
      cn.Execute " delete from 图书 where 书号 =" & "'" & Text1.Text & "'"
      tushu.Refresh
      If tushu.Recordset.BOF And tushu.Recordset.EOF Then
        MsgBox "表已清空！"
        Exit Sub
      Else
        tushu.Recordset.AbsolutePosition = lgNum
        tushu.Recordset.MoveLast
      End If
    End If
    addtshad = False
Exit Sub
cmdtsdelerr:
MsgBox Err.Description
End Sub

'删除期刊记录
Private Sub cmdqkdel_Click()
Dim lgNum As Long
On Error GoTo cmdqkdelerr
    Dim nYN As Byte
     nYN = MsgBox("您正准备删除当前记录。" & Chr(13) & Chr(13) & _
        "假如您单击“是”，您将不能撤消这个删除操作。" & Chr(13) & _
        "您确认删除这条记录吗?", vbExclamation + vbYesNo)
    If nYN = vbYes Then
      lgNum = qikan.Recordset.AbsolutePosition
      cn.Execute " delete from 期刊 where 书号 =" & "'" & Text15.Text & "'"
      qikan.Refresh
      If qikan.Recordset.BOF And qikan.Recordset.EOF Then
        MsgBox "表已清空！"
        Exit Sub
      Else
        qikan.Recordset.AbsolutePosition = lgNum
        qikan.Recordset.MoveLast
      End If
    End If
    addqkhad = False
Exit Sub
cmdqkdelerr:
MsgBox Err.Description
End Sub

'涮新图书记录
Private Sub cmdtsrefresh_Click()
'只有多用户应用程序需要
On Error GoTo cmdtsrefresherr
tushu.Refresh
Exit Sub
cmdtsrefresherr:
MsgBox Err.Description
End Sub

Private Sub UserDocument_Initialize()
pIP = cname(pIP)
pConn = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=booklib;Data Source=" & pIP

    cn.Open pConn

    With tushu
        .ConnectionString = pConn
        .RecordSource = "图书"
        .Refresh
        If Not .Recordset.EOF Or Not .Recordset.BOF Then
            .Recordset.MoveLast
        End If
    End With
    With qikan
        .ConnectionString = pConn
        .RecordSource = "期刊"
        .Refresh
        If Not .Recordset.EOF Or Not .Recordset.BOF Then
            .Recordset.MoveLast
        End If
    End With
    '初始化语种
    With Adodc1
        .ConnectionString = pConn
        .RecordSource = "语种"
        .Refresh
    End With
    With DataCombo1
        Set .DataSource = tushu
        .DataField = "语种"
        Set .RowSource = Adodc1
        .ListField = "语种"
        .BoundColumn = "语种"
    End With
    With DataCombo6
        Set .DataSource = qikan
        .DataField = "语种"
        Set .RowSource = Adodc1
        .ListField = "语种"
        .BoundColumn = "语种"
    End With

    '初始化分类
    With Adodc2
        .ConnectionString = pConn
        .RecordSource = "分类"
        .Refresh
    End With
    With DataCombo2
        Set .DataSource = tushu
        .DataField = "分类"
        Set .RowSource = Adodc2
        .ListField = "分类"
        .BoundColumn = "分类"
    End With
    With DataCombo7
        Set .DataSource = qikan
        .DataField = "分类"
        Set .RowSource = Adodc2
        .ListField = "分类"
        .BoundColumn = "分类"
    End With

    '初始化借阅对象
    With Adodc3
        .ConnectionString = pConn
        .RecordSource = "借阅对象"
        .Refresh
    End With
    With DataCombo3
        Set .DataSource = tushu
        .DataField = "借阅对象"
        Set .RowSource = Adodc3
        .ListField = "借阅对象"
        .BoundColumn = "借阅对象"
    End With
    With DataCombo8
        Set .DataSource = qikan
        .DataField = "借阅对象"
        Set .RowSource = Adodc3
        .ListField = "借阅对象"
        .BoundColumn = "借阅对象"
    End With

    '初始化存放地点
    With Adodc4
        .ConnectionString = pConn
        .RecordSource = "存放地点"
        .Refresh
    End With
    With DataCombo9
        Set .DataSource = qikan
        .DataField = "存放地点"
        Set .RowSource = Adodc4
        .ListField = "存放地点"
        .BoundColumn = "存放地点"
    End With


    '初始化配套资料介质
    With Adodc5
        .ConnectionString = pConn
        .RecordSource = "配套资料介质"
        .Refresh
    End With
    With DataCombo5
        Set .DataSource = tushu
        .DataField = "配套资料介质"
        Set .RowSource = Adodc5
        .ListField = "配套资料介质"
        .BoundColumn = "配套资料介质"
    End With
    With DataCombo10
        Set .DataSource = qikan
        .DataField = "配套资料介质"
        Set .RowSource = Adodc5
        .ListField = "配套资料介质"
        .BoundColumn = "配套资料介质"
    End With

    Combo1.AddItem "64开"
    Combo1.AddItem "32开"
    Combo1.AddItem "16开"
    Combo1.AddItem "8开"
    Combo1.AddItem "4开"

End Sub

Private Sub tushu_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
'错误处理程序代码置于此处
'想要忽略错误，注释掉下一行
'想要捕获它们，在此添加代码以处理它们
MsgBox "Data error event hit err:" & Description
End Sub

Private Sub qikan_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
'错误处理程序代码置于此处
'想要忽略错误，注释掉下一行
'想要捕获它们，在此添加代码以处理它们
MsgBox "Data error event hit err:" & Description
End Sub
'添加图书记录
Private Sub cmdtsadd_Click()
On Error GoTo cmdtsadderr
    If addtshad = False Then
        tushu.Recordset.AddNew
        addtshad = True
    Else
        MsgBox "你已经按了一次,请不要重复按！"
    End If
Exit Sub
cmdtsadderr:
MsgBox Err.Description
End Sub

'添加期刊记录
Private Sub cmdqkadd_Click()
On Error GoTo cmdqkadderr
    If addqkhad = False Then
        qikan.Recordset.AddNew
        addqkhad = True
    Else
        MsgBox "你已经按了一次,请不要重复按！"
    End If
Exit Sub
cmdqkadderr:
MsgBox Err.Description
End Sub

Private Sub UserDocument_Terminate()
rs.Close
cn.Close
End Sub