Option Compare Database
' 引用 Microsoft Scripting Runtime
Option ExplicitPrivate Function getDH(strPath)getDH = Right(strPath, 12)
End FunctionPrivate 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 acCmdAppMinimizeDoCmd.ShowToolbar "Ribbon", acToolbarNo ' 隐藏功能区代码DoCmd.RunCommand acCmdAppMinimize ' 让主窗体最大化
End SubPrivate Sub btnCD_Click()Dim fd As FileDialogSet fd = Application.FileDialog(msoFileDialogFolderPicker)If fd.Show = -1 ThenMe.txtPath = fd.SelectedItems(1)End If
End SubPrivate Sub btnFJ_Click()On Error GoTo Err_btnFJ_ClickDim qzh, mlh, ajh, dh, lbh, FolderSpec, sou_fil, des_fil, des_flo As StringDim ys As IntegerDim rs As ObjectDim strSQL As StringDim i As IntegerFolderSpec = Me.txtPathDim fs, f, f1, fc, sSet 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 TruestrSQL = "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, adLockOptimisticIf rs.RecordCount > 0 Thenrs.MoveFirstElseMsgBox ("无录入信息 或 文件夹选择错误 ！")End IfDo While Not rs.EOFlbh = rs!lbhys = CInt(rs!ys)For i = 1 To ysSet f = fs.GetFolder(FolderSpec)Set fc = f.FilesFor Each f1 In fcsou_fil = f1des_flo = Me.txtPath & "\" & lbhdes_fil = Me.txtPath & "\" & lbh & "\" & f1.NameIf Not fs.FolderExists(des_flo) Then fs.CreateFolder (des_flo)fs.MoveFile sou_fil, des_filGoTo next_picNext
next_pic:Next irs.MoveNextLoop
Exit_btnFJ_Click:'恢复鼠标指针DoCmd.Hourglass False'释放对象变量内存Set rs = NothingSet fs = NothingExit SubErr_btnFJ_Click: '错误处理程序If Err = 70 ThenMsgBox "不能替换文件，因为无法删除已有文件，可能的原因有：" & vbCrLf & vbCrLf & _"1.该文件处于打开状态。" & vbCrLf & _"2.没有对此目录的写入权限。", vbCriticalElseMsgBox Err.Description, vbCritical, "错误#" & ErrEnd IfResume Exit_btnFJ_ClickEnd SubPrivate Sub Form_Unload(Cancel As Integer)Application.Quit acQuitSaveNoneEnd Sub