资源下载: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