【列表框查询窗体】【列表框联动】【批量导入导出附件中的文件】
列表框查询窗体
Dim cj_filter As String
Private Sub Command查询_Click()
On Error GoTo 结束查询
If Me.查询字段 = "考试日期" Then
If 起始日期 <> "" And IsNull(起始日期) = False And 截止日期 <> "" And IsNull(截止日期) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
cj_filter = "Select * from 学生成绩表 Where " & Me.查询字段 & " between #" & Me.起始日期 & "# and #" & Me.截止日期 & "#"
Me.列表框1.RowSource = cj_filter
Else
cj_filter = "Select * From 学生成绩表"
Me.列表框1.RowSource = cj_filter
End If
Exit Sub
End If
If Me.查询字段 = "分数" Then
If 最小 <> "" And IsNull(最小) = False And 最大 <> "" And IsNull(最大) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
cj_filter = "Select * from 学生成绩表 Where " & Me.查询字段 & " >= " & Me.最小 & " And " & Me.查询字段 & " <= " & Me.最大
Me.列表框1.RowSource = cj_filter
Else
cj_filter = "Select * From 学生成绩表"
Me.列表框1.RowSource = cj_filter
End If
Exit Sub
End If
If 查询内容 <> "" And IsNull(查询内容) = False And 查询字段 <> "" And IsNull(查询字段) = False Then
cj_filter = "Select * From 学生成绩表 Where " & Me.查询字段 & " like '*" & Me.查询内容 & "*'"
Me.列表框1.RowSource = cj_filter
Else
cj_filter = "Select * From 学生成绩表"
Me.列表框1.RowSource = cj_filter
End If
Exit Sub
结束查询:
MsgBox Err.Description
End Sub
Private Sub Command全部_Click()
cj_filter = "Select * From 学生成绩表"
Me.列表框1.RowSource = cj_filter
End Sub
Private Sub Form_Load()
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End Sub
Private Sub 查询字段_Change()
If Me.查询字段 = "考试日期" Then
Me.起始日期.Visible = True
Me.截止日期.Visible = True
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
If Me.查询字段 = "分数" Then
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = True
Me.最大.Visible = True
Me.查询内容.Visible = False
Exit Sub
Else
Me.起始日期.Visible = False
Me.截止日期.Visible = False
Me.最小.Visible = False
Me.最大.Visible = False
Me.查询内容.Visible = True
End If
End Sub
列表框联动
Private Sub 列表框1_DblClick(Cancel As Integer)
If IsNull(列表框1.Value) = False Then
Me.列表框2.RowSource = "SELECT ID, 二级项目 FROM 二级表 WHERE 一级项目='" & 列表框1.Value & "'"
Me.列表框3.RowSource = ""
End If
End Sub
Private Sub 列表框2_DblClick(Cancel As Integer)
If IsNull(列表框2.Value) = False Then
Me.列表框3.RowSource = "SELECT 三级项目 FROM 三级表 WHERE 二级ID=" & Me.列表框2.Value
End If
End Sub
批量导入导出附件中的文件
Private Sub Command导出_Click() '导出
'选择导出的位置（文件夹）
Dim exportpath As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
If .Show = -1 Then
exportpath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Dim filers As Recordset
Dim filerecord As Recordset
Set filerecord = CurrentDb.OpenRecordset("文件记录表", dbOpenTable)
Do While filerecord.EOF = False
If filerecord.Fields("选择").Value = True Then
Set filers = filerecord.Fields("文件附件").Value
Do While filers.EOF = False
filers.Fields("FileData").SaveToFile exportpath
filers.MoveNext
Loop
End If
filerecord.MoveNext
Loop
MsgBox "导出完成"
End Sub
Private Sub Command添加_Click() '添加
On Error Resume Next
Dim vrtSelectedItem
Dim newid As Long
Dim filers As Recordset
Dim filerecord As Recordset
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
If .Show = -1 Then
Set filerecord = CurrentDb.OpenRecordset("文件记录表", dbOpenTable)
For Each vrtSelectedItem In .SelectedItems
'获取文件名和路径
DoCmd.SetWarnings (False)
Dim add_sql As String
add_sql = "Insert Into 文件记录表 (文件名称) Values ('" & 处理文件名(vrtSelectedItem) & "')"
DoCmd.RunSQL add_sql
'获取最新ID
newid = Nz(DMax("ID", "文件记录表"), 0)
If newid <> 0 Then '上传附件
filerecord.MoveLast
filerecord.Edit
Set filers = filerecord.Fields("文件附件").Value
filers.AddNew
filers.Fields("Filedata").LoadFromFile vrtSelectedItem
filers.Update
filers.Close
filerecord.Update
End If
Next vrtSelectedItem
Else
Exit Sub
End If
End With
Me.数据表子窗体.Requery
End Sub
Function 处理文件名(ByVal filepathname As String) As String
On Error Resume Next
处理文件名 = ""
Dim a1 As Long
a1 = InStrRev(filepathname, "\")
处理文件名 = Right(filepathname, Len(filepathname) - a1)
End Function
