[ACCESS][小工具]根据数据库信息分件（临时分件用）

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