Option Compare Database
' 引用 Microsoft Scripting Runtime
Option Explicit
Private Function getDH(strPath)
getDH = Right(strPath, 12)
End Function
Private Sub Form_Load()
'居中显示
' DoCmd.Echo False
' Dim x, y As Integer
' DoCmd.Maximize
' x = Me.WindowWidth
' y = Me.WindowHeight
' DoCmd.Restore
' DoCmd.Echo True
' Move (x - Me.WindowWidth) / 2 - 2000, (y - Me.WindowHeight) / 2 - 4000
'
' 'Move 1000, -1100
' DoCmd.RunCommand acCmdAppMinimize
DoCmd.ShowToolbar "Ribbon", acToolbarNo ' 隐藏功能区代码
DoCmd.RunCommand acCmdAppMinimize ' 让主窗体最大化
End Sub
Private Sub btnCD_Click()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
Me.txtPath = fd.SelectedItems(1)
End If
End Sub
Private Sub btnFJ_Click()
On Error GoTo Err_btnFJ_Click
Dim qzh, mlh, ajh, dh, lbh, FolderSpec, sou_fil, des_fil, des_flo As String
Dim ys As Integer
Dim rs As Object
Dim strSQL As String
Dim i As Integer
FolderSpec = Me.txtPath
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(FolderSpec)
qzh = Left(getDH(Me.txtPath), 3)
mlh = Mid(getDH(Me.txtPath), 5, 2)
ajh = Right(getDH(Me.txtPath), 5)
dh = qzh & "-" & mlh & "-" & ajh
'设置鼠标指针为沙漏形状
DoCmd.Hourglass True
strSQL = "Select QZH,MLH,AJH,LBH,YS,JXH FROM JIAN WHERE (QZH='" & qzh & "' AND MLH='" & mlh & "' AND AJH='" & ajh & "') ORDER BY CInt(JXH)"
Set rs = CreateObject("ADODB.Recordset")
rs.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
If rs.RecordCount > 0 Then
rs.MoveFirst
Else
MsgBox ("无录入信息 或 文件夹选择错误 !")
End If
Do While Not rs.EOF
lbh = rs!lbh
ys = CInt(rs!ys)
For i = 1 To ys
Set f = fs.GetFolder(FolderSpec)
Set fc = f.Files
For Each f1 In fc
sou_fil = f1
des_flo = Me.txtPath & "\" & lbh
des_fil = Me.txtPath & "\" & lbh & "\" & f1.Name
If Not fs.FolderExists(des_flo) Then fs.CreateFolder (des_flo)
fs.MoveFile sou_fil, des_fil
GoTo next_pic
Next
next_pic:
Next i
rs.MoveNext
Loop
Exit_btnFJ_Click:
'恢复鼠标指针
DoCmd.Hourglass False
'释放对象变量内存
Set rs = Nothing
Set fs = Nothing
Exit Sub
Err_btnFJ_Click: '错误处理程序
If Err = 70 Then
MsgBox "不能替换文件,因为无法删除已有文件,可能的原因有:" & vbCrLf & vbCrLf & _
"1.该文件处于打开状态。" & vbCrLf & _
"2.没有对此目录的写入权限。", vbCritical
Else
MsgBox Err.Description, vbCritical, "错误#" & Err
End If
Resume Exit_btnFJ_Click
End Sub
Private Sub Form_Unload(Cancel As Integer)
Application.Quit acQuitSaveNone
End Sub