[EXCEL][VBA][ACCESS]业务档案录入系统

资源下载：https://download.csdn.net/download/gonery/20605736

主界面：

 代码：

sheet1

Option Explicit

Private Sub delete_dh()
    Dim cSQL As String
    
    Call cnn_MDB
    
    cSQL = "Insert Into yw_aj_bak Select * From yw_aj Where dh='" & Me.txt_search & "'"
    cnn.Execute cSQL
    
    cSQL = "Delete From yw_aj Where dh='" & Me.txt_search & "'"
    cnn.Execute cSQL
    
    cSQL = "Insert Into yw_jn_bak Select * From yw_jn Where ajjdh='" & Me.txt_search & "'"
    cnn.Execute cSQL
    
    cSQL = "Delete From yw_jn Where ajjdh='" & Me.txt_search & "'"
    cnn.Execute cSQL
End Sub

Private Sub btn_delete_Click()
    Dim rp     'rp: Response 响应
    rpe = MsgBox("确定要删除此档案？", vbYesNoCancel)
    If rp = vbYes Then
        Call cls_ALL
        Call delete_dh
        Call init_BTN
    ElseIf rp = vbNo Then
        Call cls_ALL
        Call init_BTN
    End If
    
    
End Sub

Private Sub btn_init_Click()
    Call cls_ALL
    Call init_BTN
    Sheet1.txt_search = Null

    'MsgBox Range("F65536").End(xlUp).Row

End Sub

Private Sub btn_print_cover_Click()     '通过查找打印封面，封面信息从表中获取
    Dim rSQL As String
    
    '--------------------------------------------获取案卷信息
    Dim u_jm As String    '卷名称，如AJ3对应“审理卷”
    Dim t_dh              '带临时全宗号的档号
    t_dh = Range("B3")
    u_nd = Range("B2")
    u_fnh = Range("E2")
    u_ajh = Range("H2")
    u_fch = Range("K2")
    u_dh = Range("B3")
    u_bgqx = Range("H3")
    u_ys = Range("K3")
    u_tm = Range("B4")
    'u_qzh = left(u_dh,3)
    u_qzh = "    "      '洋浦暂无 全宗号
    u_dh = u_qzh & "-" & u_nd & "-" & u_fnh & "-" & u_ajh & "-" & u_fch     '重新赋值档号，洋浦暂时无 全宗号，留空
    Select Case u_fnh
        Case "AJ1"
            u_jm = "违纪违法卷"
        Case "AJ2"
            u_jm = "职务犯罪卷"
        Case "AJ3"
            u_jm = "审理卷"
        Case "AJ4"
            u_jm = "申诉卷"
        Case "AJ5"
            u_jm = "审查调查内卷"
        Case "AJ6"
            u_jm = "监督检查卷"
        Case "AJ7"
            u_jm = "问责卷"
        Case "AJ9"
            u_jm = "卷"
    End Select
    '--------------------------------------------获取分册总数
    Dim fc_num As Integer
    rSQL = "Select dh From yw_aj Where dh like '" & Left(t_dh, Len(t_dh) - 4) & "%'"
    Call cnn_MDB
    rst.Open rSQL, cnn, 1, 3
    fc_num = rst.RecordCount    '分册总数
    rst.Close
    '--------------------------------------------获取卷内材料最大日期、最小日期
    Dim max_jnrq As String
    Dim min_jnrq As String
        
    '最小日期
    rSQL = "Select min(rq) From yw_jn Where ajjdh='" & t_dh & "' And "
    rSQL = rSQL & "rq <> '00000000' And "
    rSQL = rSQL & "left(rq,4) <> '0000'"
    rst.Open rSQL, cnn, 1, 3
    If Not rst.EOF Or Not rst.BOF Then rst.MoveFirst
    min_jnrq = rst.Fields(0)
    rst.Close
    '最大日期
    rSQL = "Select max(rq) From yw_jn Where ajjdh='" & t_dh & "' And "
    rSQL = rSQL & "rq <> '00000000' And "
    rSQL = rSQL & "left(rq,4) <> '0000'"
    rst.Open rSQL, cnn, 1, 3
    If Not rst.EOF Or Not rst.BOF Then rst.MoveFirst
    max_jnrq = rst.Fields(0)
    rst.Close
    
    '--------------------------------------------打开模板回填信息
    Dim tml_path As String  '模板路径
    

    tml_path = ThisWorkbook.Path & "\Templates\cover.xlsx"
    Workbooks.Open tml_path
    With ActiveSheet
        .Range("F14") = u_jm
        .Range("J19") = u_dh
        .Range("I25") = u_tm
        .Range("H43") = Left(min_jnrq, 4)
        .Range("L43") = Abs(Mid(min_jnrq, 5, 2))
        .Range("Q43") = Left(max_jnrq, 4)
        .Range("U43") = Abs(Mid(max_jnrq, 5, 2))
        
        .Range("AD43") = u_bgqx
        .Range("J47") = fc_num
        .Range("P47") = Abs(u_fch)
        .Range("T47") = Abs(u_ys)
        .Range("T56") = u_qzh      '暂无 全宗号
        .Range("X56") = u_nd & "-" & u_fnh
        .Range("AF56") = Abs(u_fch)
    
        '--------------------------------------------打印
        .PrintOut
    End With
    
    Workbooks("cover.xlsx").Close SaveChanges:=False
    
    Call cls_RST
    Call cls_CNN
    
End Sub

Private Sub btn_print_menu_Click()
    
'    Dim rSQL As String
    u_bgqx = Range("H3")
    Dim iRow As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim ub As Integer
    Dim menu_arr()
    iRow = Range("F" & jn_last).End(xlUp).Row
    ub = iRow - jn_first + 1
    ReDim menu_arr(1 To 7, 1 To ub)
    '--------------------------------------------读取录入表卷内信息
    For i = 1 To 7
        Select Case i
            Case 1
                For j = 1 To ub
                    k = j + jn_first - 1
                    menu_arr(i, j) = Range("A" & k)
                Next
            Case 2
                For j = 1 To ub
                    k = j + jn_first - 1
                    menu_arr(i, j) = Range("B" & k)
                Next
            Case 3
                For j = 1 To ub
                    k = j + jn_first - 1
                    menu_arr(i, j) = Range("D" & k)
                Next
            Case 4
                For j = 1 To ub
                    k = j + jn_first - 1
                    menu_arr(i, j) = Range("F" & k)
                Next
            Case 5
                For j = 1 To ub
                    k = j + jn_first - 1
                    menu_arr(i, j) = Range("K" & k)
                Next
            Case 6
                For j = 1 To ub
                    k = j + jn_first - 1
                    menu_arr(i, j) = Range("L" & k)
                Next
            Case 7
                For j = 1 To ub
                    k = j + jn_first - 1
                    menu_arr(i, j) = Range("M" & k)
                Next
        End Select
    Next
    '--------------------------------------------打开模板回填信息
    Dim tml_path As String  '模板路径
    tml_path = ThisWorkbook.Path & "\Templates\menu.xlsx"
    Workbooks.Open (tml_path)
    '--------------------------------------------根据目录行数插入相应行，保证整页有表格
    Dim insPage As Integer

'    If ub > 11 And ub Mod 11 > 0 Then
'        insPage = ub \ 11 + 1
'    ElseIf ub > 11 And ub Mod 11 = 0 Then
'        insPage = ub \ 11
'    Else
'        insPage = 0
'    End If
    If ub > 11 Then insPage = ub \ 11
    
    With ActiveSheet
        If insPage > 0 Then
            For i = 1 To insPage * 11
                ActiveSheet.Rows(5).Insert
            Next
        End If
        
        For i = 1 To 6
            Select Case i
                Case 1
                    For j = 1 To ub
                        k = j + 3
                        .Range("A" & k) = menu_arr(i, j)
                    Next
                Case 2
                    For j = 1 To ub
                        k = j + 3
                        .Range("C" & k) = menu_arr(i, j)
                    Next
                Case 3
                    For j = 1 To ub
                        k = j + 3
                        .Range("B" & k) = menu_arr(i, j)
                    Next
                Case 4
                    For j = 1 To ub
                        k = j + 3
                        If Len(menu_arr(7, j)) > 0 Then
                            .Range("D" & k) = menu_arr(i, j) & "（" & menu_arr(7, j) & "）"
                        Else
                            .Range("D" & k) = menu_arr(i, j)
                        End If
                    Next
                Case 5
                    For j = 1 To ub
                        k = j + 3
                        If menu_arr(i, j) = "00000000" Then
                            .Range("E" & k) = ""
                        ElseIf Left(menu_arr(i, j), 4) = "0000" Then
                            .Range("E" & k) = Right(menu_arr(i, j), 4)
                        ElseIf Right(menu_arr(i, j), 4) = "0000" Then
                            .Range("E" & k) = Left(menu_arr(i, j), 4)
                        Else
                            .Range("E" & k) = menu_arr(i, j)
                        End If
                    Next
                Case 6
                    For j = 1 To ub
                        k = j + 3
                        .Range("F" & k) = menu_arr(i, j)
                    Next
            End Select
        Next
        .Range("G2") = u_bgqx
        .PrintOut
    End With
    
    Workbooks("menu.xlsx").Close SaveChanges:=False

End Sub

Private Sub btn_search_Click()
    
    Dim rSQL As String
    Dim i As Integer
    
    If Me.txt_search = "" Or Me.txt_search = Null Then Me.txt_search.Activate: Exit Sub
    Call cls_ALL
    Call cnn_MDB    '连接数据库
    
    '--------------------------------------------案卷信息回填
    rSQL = "Select nd, fnh, ajh, fch, dh, bgqx, ys, tm, zrz, shr, rq, mj, kzbs From yw_aj Where dh='" & Me.txt_search & "'"
    rst.Open rSQL, cnn, 1, 3    '打开查询记录集
    If rst.RecordCount < 1 Then '无记录
        MsgBox "查无此档！"
        Call cls_RST
        Call cls_CNN
        Exit Sub
    ElseIf rst.RecordCount > 1 Then     '记录大于1，写入数据库有bug，档号为唯一值
        MsgBox "记录大于1，请联系管理员！"
        Call cls_RST
        Call cls_CNN
        Exit Sub
    Else
        rst.MoveFirst   '数据回填到表
        Range("B2") = rst!nd
        Range("E2") = rst!fnh
        Range("H2") = rst!ajh
        Range("K2") = rst!fch
        'Range("B3") = rst!dh
        'Range("H3") = rst!bgqx
        Range("K3") = rst!ys
        Range("B4") = rst!tm
        Range("B5") = rst!zrz
        Range("E5") = rst!shr
        Range("H5") = rst!rq
        Range("J5") = rst!mj
        Range("L5") = rst!kzbs
        rst.Close   '关闭查询记录集
    End If
    
    '--------------------------------------------卷内信息回填
    rSQL = "Select zrz,wjbh,tm,rq,ym,rm,mj,kzbs,ajjdh,jh From yw_jn where ajjdh='" & Me.txt_search & "' Order by jh"
    rst.Open rSQL, cnn, 1, 3
    If Not rst.BOF Or Not rst.EOF Then rst.MoveFirst
    i = jn_first
    Do While Not rst.EOF
        Range("B" & i) = rst!zrz
        Range("D" & i) = rst!wjbh
        Range("F" & i) = rst!tm
        Range("K" & i) = rst!rq
        Range("L" & i) = rst!ym
        Range("M" & i) = rst!rm
        Range("N" & i) = rst!mj
        Range("O" & i) = rst!kzbs
        i = i + 1
        rst.MoveNext
    Loop
    Me.btn_updata.Enabled = True
    Me.btn_delete.Enabled = True
    Me.btn_print_cover.Enabled = True
    Me.btn_print_menu.Enabled = True
    Me.btn_submit.Enabled = False

    Range("B2").Select
    
    Call cls_RST
    Call cls_CNN
End Sub

Private Sub btn_submit_Click()
    'On Error GoTo Err_Info
    Dim cSQL, rSQL As String
    Dim i, j As Integer
    
    '--------------------案卷信息
    '----------变量赋值（待完善，可加入字段录入规则，必填字段为空提示等）
    u_nd = Range("B2")
    u_fnh = Range("E2")
    u_ajh = Range("H2")
    u_fch = Range("K2")
    u_dh = Range("B3")
    u_qzh = Left(u_dh, 5)
    u_bgqx = Range("H3")
    u_ys = Range("K3")
    u_tm = Range("B4")
    u_zrz = Range("B5")
    u_shr = Range("E5")
    u_rq = Range("H5")
    u_mj = Range("J5")
    u_kzbs = Range("L5")
    u_station = "1"
    u_in_date = Now()
    u_in_user = "user"
    
    '----------SQL语句，添加案卷信息
    cSQL = "INSERT INTO yw_aj(nd, fnh, ajh, fch, dh, qzh, bgqx, ys, tm, zrz, rq, mj, kzbs,shr,station,in_date,in_user) VALUES("
    cSQL = cSQL & "'" & u_nd & "'" & ","
    cSQL = cSQL & "'" & u_fnh & "'" & ","
    cSQL = cSQL & "'" & u_ajh & "'" & ","
    cSQL = cSQL & "'" & u_fch & "'" & ","
    cSQL = cSQL & "'" & u_dh & "'" & ","
    cSQL = cSQL & "'" & u_qzh & "'" & ","
    cSQL = cSQL & "'" & u_bgqx & "'" & ","
    cSQL = cSQL & "'" & u_ys & "'" & ","
    cSQL = cSQL & "'" & u_tm & "'" & ","
    cSQL = cSQL & "'" & u_zrz & "'" & ","
    cSQL = cSQL & "'" & u_rq & "'" & ","
    cSQL = cSQL & "'" & u_mj & "'" & ","
    cSQL = cSQL & "'" & u_kzbs & "'" & ","
    cSQL = cSQL & "'" & u_shr & "'" & ","
    cSQL = cSQL & "'" & u_station & "'" & ","
    cSQL = cSQL & "'" & u_in_date & "'" & ","
    cSQL = cSQL & "'" & u_in_user & "'"
    cSQL = cSQL & ")"
    
    '----------数据库连接
    Call cnn_MDB
    '----------数据库操作（检查数据库中是否存在该卷档号、件档号）
    rSQL = "Select dh From yw_aj Where dh='" & u_dh & "'"  'SQL语句：查找有无此档号的记录
    rst.Open rSQL, cnn, 1, 3 '打开记录集
    If Not rst.EOF Or Not rst.BOF Then  '案卷记录不为空，错误提示并退出
        MsgBox "此档号已存在，请检查！"
        rst.Close
        cnn.Close
        Set rst = Nothing
        Set rst = Nothing
        Exit Sub
    Else    '案卷记录为空，检查
        rst.Close   '关闭案卷记录集
        i = Range("F65536").End(xlUp).Row   'F列有数据最后一行行号
        If i < jn_first Then
            MsgBox "未录入卷内信息！"
            cnn.Close
            Set rst = Nothing
            Set cnn = Nothing
            Exit Sub
        End If
        For j = jn_first To i
            rSQL = "Select dh From yw_jn Where dh='" & u_dh & "-" & Format(Range("A" & j), "0000") & "'"
            rst.Open rSQL, cnn, 1, 3
            If Not rst.EOF Or Not rst.BOF Then  '卷内记录不为空，错误提示并退出
                MsgBox "此件档号已存在，但无卷档号，请检查！"
                rst.Close
                cnn.Close
                Set rst = Nothing
                Set cnn = Nothing
                Exit Sub
            Else
                rst.Close
            End If
        Next
    End If
        
    '----------数据库操作，添加案卷信息
    cnn.Execute (cSQL)
    
    '--------------------卷内信息
    '----------变量赋值（待完善，可加入字段录入规则，必填字段为空提示等）
   
    For j = jn_first To i
        j_jh = Format(Range("A" & j), "0000")
        j_zrz = Range("B" & j)
        j_wjbh = Range("D" & j)
        j_tm = Range("F" & j)
        j_rq = Range("K" & j)
        j_ym = Range("L" & j)
        j_rm = Range("M" & j)
        j_mj = Range("N" & j)
        j_kzbs = Range("O" & j)
        j_dh = u_dh & "-" & j_jh
        j_station = "1"
        j_in_date = Now()
        j_in_user = "user"
        
        '----------SQL语句
        cSQL = "INSERT INTO yw_jn(nd, fnh, ajh, fch, dh, qzh, bgqx, jh, ym, tm, zrz, rq, wjbh, mj, kzbs, ajjdh, rm, station,in_date,in_user) VALUES("
        cSQL = cSQL & "'" & u_nd & "'" & ","
        cSQL = cSQL & "'" & u_fnh & "'" & ","
        cSQL = cSQL & "'" & u_ajh & "'" & ","
        cSQL = cSQL & "'" & u_fch & "'" & ","
        cSQL = cSQL & "'" & j_dh & "'" & ","
        cSQL = cSQL & "'" & u_qzh & "'" & ","
        cSQL = cSQL & "'" & u_bgqx & "'" & ","
        cSQL = cSQL & "'" & j_jh & "'" & ","
        cSQL = cSQL & "'" & j_ym & "'" & ","
        cSQL = cSQL & "'" & j_tm & "'" & ","
        cSQL = cSQL & "'" & j_zrz & "'" & ","
        cSQL = cSQL & "'" & j_rq & "'" & ","
        cSQL = cSQL & "'" & j_wjbh & "'" & ","
        cSQL = cSQL & "'" & j_mj & "'" & ","
        cSQL = cSQL & "'" & j_kzbs & "'" & ","
        cSQL = cSQL & "'" & u_dh & "'" & ","
        cSQL = cSQL & "'" & j_rm & "'" & ","
        cSQL = cSQL & "'" & j_station & "'" & ","
        cSQL = cSQL & "'" & j_in_date & "'" & ","
        cSQL = cSQL & "'" & j_in_user & "'"
        cSQL = cSQL & ")"
        cnn.Execute (cSQL)
    Next
    
    '----------关闭数据库
    Call cls_RST
    Call cls_CNN
    
    MsgBox "录入信息已保存，继续录入。"
    
    Call cls_JN
'Exit Sub

'Err_Info:
'    On Error Resume Next
'    rst.Close
'    cnn.Close
'    Set rst = Nothing
'    Set cnn = Nothing
'    Application.Cursor = xlDefault
'    MsgBox "错误代码：" & Err.Number & vbCrLf & "错误信息：" & Err.Description

End Sub

Private Sub cls_JN()
    Dim i As Integer
    For i = jn_first To jn_last
        Range("B" & i) = Null
        Range("D" & i) = Null
        Range("F" & i) = Null
        Range("K" & i) = Null
        Range("L" & i) = Null
        Range("M" & i) = Null
        Range("N" & i) = "内部"
        Range("O" & i) = Null
    Next
    Range("B2").Select
End Sub

Private Sub cls_ALL()
    Dim i As Integer
    Range("B2") = Null
    Range("E2") = Null
    Range("H2") = Null
    Range("K2") = Null
    Range("K3") = Null
    Range("B4") = Null
    Range("B5") = Null
    Range("E5") = Null
    Range("H5") = Null
    Range("J5") = "内部"
    Range("L5") = Null
    For i = jn_first To jn_last
        Range("B" & i) = Null
        Range("D" & i) = Null
        Range("F" & i) = Null
        Range("K" & i) = Null
        Range("L" & i) = Null
        Range("M" & i) = Null
        Range("N" & i) = "内部"
        Range("O" & i) = Null
    Next
    Range("B2").Select
End Sub

Private Sub btn_test_Click()
    Call btn_print_cover_Click
End Sub

Private Sub btn_updata_Click()
    Call delete_dh
    Call btn_submit_Click
    Call init_BTN
End Sub

thisworkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.DisplayAlerts = False
    Application.Quit
End Sub

Private Sub Workbook_Open()
    Sheet1.Range("B2").Select
    'Sheet1.Range("B2").Activate
    Call init_BTN
    Sheet1.txt_search = Null
End Sub

模块1

'================================================
'------------------------------------------------公共变量声明
Public cnn As Object
Public rst As Object
Public db_path As String

Public u_nd As String
Public u_fnh As String
Public u_ajh As String
Public u_fch As String
Public u_dh As String
Public u_qzh As String
Public u_bgqx As String
Public u_ys As String
Public u_tm As String
Public u_zrz As String
Public u_shr As String
Public u_rq As String
Public u_mj As String
Public u_kzbs As String
Public u_station As String
Public u_in_data As String
Public u_in_user As String

Public j_jh As String
Public j_rq As String
Public j_wjbh As String
Public j_zrz As String
Public j_tm As String
Public j_rm As String
Public j_ym As String
Public j_mj As String
Public j_kzbs As String
Public j_station As String
Public j_in_data As String
Public j_in_user As String

'------------------------------------------------公共常量声明
Public Const jn_first = 10 '卷内数据第一行行号
Public Const jn_last = 109  '卷内数据最大行行号

'================================================
'过程名：cnn_MDB
'参数：无
'作用：建立与数据库的连接
'------------------------------------------------
Sub cnn_MDB()
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
    db_path = "\\192.168.1.110\mdb\yp_data.accdb"

    With cnn
        If Val(Application.Version) < 12 Then
            .Provider = "Microsoft.Ace.OLEDB.4.0"
        Else
            .Provider = "Microsoft.Ace.OLEDB.12.0"
        End If
        .Open db_path
    End With
End Sub

'================================================
'过程名：cls_CNN
'参数：无
'作用：关闭数据库连接
'------------------------------------------------
Sub cls_CNN()
    If cnn.State = 1 Then cnn.Close: Set cnn = Nothing
End Sub

'================================================
'过程名：cls_RST
'参数：无
'作用：关闭记录集连接
'------------------------------------------------
Sub cls_RST()
    If rst.State = 1 Then rst.Close: Set rst = Nothing
End Sub

'================================================
'函数名：check_k()
'参数：cdata，待检查数据
'作用：检查cdata是否是空字符
'------------------------------------------------
Function check_k(cdata)
    If Trim(cdata) = "" Or Trim(cdata) = Null Then
        check_k = True
    Else
        check_null = False
    End If
End Function

'================================================
'过程名：init_btn
'参数：无
'作用：初始化按钮状态
'------------------------------------------------
Sub init_BTN()
    
    Sheet1.btn_test.Visible = False


    Sheet1.btn_updata.Enabled = False
    Sheet1.btn_delete.Enabled = False
    Sheet1.btn_print_cover.Enabled = False
    Sheet1.btn_print_menu.Enabled = False
    
    Sheet1.btn_submit.Enabled = True
End Sub

'================================================
'过程名：
'参数：
'作用：
'------------------------------------------------
Sub search_BTN()
    Sheet1.btn_updata.Enabled = True
    Sheet1.btn_delete.Enabled = True
    Sheet1.btn_submit.Enabled = False
End Sub