あした

Const SeikyusyoFolder       As String = "C:\Seikyusyo\"    '請求書出力フォルダー

Dim g_対象年月度            As String
Dim g_締日                  As String

'
'   「請求書」の保存フォルダを作成する。(対象年月度_締日 毎に作成)
'
'   深い階層のフォルダーを作成する場合、
'   途中のフォルダーが存在しないと[MkDirのパスが見つかりませんエラー]になるので
'   浅い階層のフォルダーから作成する。
'
Sub Seikyusyo_Flder_Crt(g_対象年月度 As String, g_締日 As String)
                                
    Dim sDoc_Folder         As String

    Dim sFolname            As String           'full path 対象年月度締日 フォルダー
    Dim arr()               As String
    Dim i                   As Long

    On Error GoTo ErrProc
    
    '----------------------------------------------------------------------------------------

    sFolname = SeikyusyoFolder & g_対象年月度 & "_" & g_締日 & "\"

    arr = Split(sFolname, "\")
    sDoc_Folder = arr(0)  ' ドライブ

    For i = 1 To UBound(arr)
        sDoc_Folder = sDoc_Folder & "\" & arr(i)
        If Dir(sDoc_Folder, vbDirectory) = "" Then
            MkDir sDoc_Folder
        End If
    Next i

Proc_EXIT:
    DoCmd.SetWarnings 1
    Exit Sub
ErrProc:
    MsgBox Err.Number & " " & Err.Description
    Resume Proc_EXIT
End Sub

Private Sub 分割品名_DblClick(CANCEL As Integer)

    Me.分割品名 = Parent!品名
    
Proc_EXIT:
    Exit Sub
ErrProc:
    MsgBox Err.Number & " " & Err.Description
    Resume Proc_EXIT
End Sub

Private Sub Form_Unload(Cancel As Integer)

  DoCmd.Quit

End Sub

Sub DLFile_rename()
                                
    Dim fso                 As Object
    Dim sData_Folder        As String
    Dim sFname              As String
    Dim sLastUpDay          As String           '更新日付

    Set fso = CreateObject("Scripting.FileSystemObject")

    sData_Folder = "\\Server\共有フォルダ\データフォルダ\"  
    sFname = Dir(sData_Folder & "xxxxxxxx*")         'file name

    Do While sFname <> ""
	'更新日付
        sLastUpDay = Replace(Left(fso.GetFile(sData_Folder & sFname).DateLastModified, 10), "/", "")        
        '日付がセットされていなければRename
        If Right(sFname, 8) <> sLastUpDay Then                                                              
            Name sData_Folder & sFname As sData_Folder & sFname & "_" & sLastUpDay                          
        End If
        
        sFname = Dir()
    Loop
    Set fso = Nothing

Proc_EXIT:
    Exit Sub
ErrProc:
    MsgBox Err.Number & " " & Err.Description
    Resume Proc_EXIT
End Sub

'
' フォームにあるコントロールを一覧表示する。
'
Public Sub Controls_name()

    Dim frm     As Form
    Dim ctl     As Control
    
    DoCmd.OpenForm "f_履歴一覧", _
    acDesign, , , , acHidden
    
    Set frm = Forms!f_履歴一覧
    
    For Each ctl In frm.Controls
        Debug.Print ctl.Name
    Next ctl
    
    DoCmd.Close acForm, "f_履歴一覧", acSaveNo

ProcExit:
    Exit Sub
ErrProc:
    MsgBox " " & Err.Number & " " & Err.Description
    Resume ProcExit
End Sub

Sub Doc_Move()
                                
    Dim fso                 As Object
    Dim sData_Folder        As String
    Dim sDoc_Folder         As String
    Dim sFname              As String

    Dim sLastUpDay          As String           '最終更新日付
    Dim sLastyyyy           As String           '最終更新年
    Dim sFolyyyy            As String           '年フォルダー

    Set fso = CreateObject("Scripting.FileSystemObject")

    sData_Folder = "\\Server\共有フォルダ\データ\"                  'InFlder
    sDoc_Folder = "\\Server\共有フォルダ\バックアップ\"             'outFolder
    sFname = Dir(sData_Folder & "DOCDOC*.pdf")                      'file name

    Do While sFname <> ""
	'最終更新日付
        sLastUpDay = Replace(Left(fso.GetFile(sData_Folder & sFname).DateLastModified, 10), "/", "")

	'年を取得        
        sLastyyyy = Left(sLastUpDay, 4)
        sFolyyyy = sDoc_Folder & sLastyyyy & "\"
        
	'年フォルダが無かったら作る
        If fso.FolderExists(sFolyyyy) = False Then                                                          
            MkDir sFolyyyy
        End If
        
	'移動
        Name sData_Folder & sFname As sFolyyyy & sLastUpDay & "_" & sFname 
        sFname = Dir()
    Loop

    Set fso = Nothing

Proc_EXIT:
    DoCmd.SetWarnings 1
    Exit Sub
ErrProc:
    MsgBox Err.Number & " " & Err.Description
    Resume Proc_EXIT
End Sub

Sub test()
    Debug.Print (ExistsWorksheet("名前"))

End Sub

' 指定した名前のシートが存在するか判定する
Public Function ExistsWorksheet(ByVal name As String)

    Dim ws              As Worksheet
    For Each ws In Sheets
        If ws.name = name Then
            ExistsWorksheet = True      ' 存在する
            Exit Function
        End If
    Next
    
    ExistsWorksheet = False             ' 存在しない
End Function

'他のフォームをRequeryする。
'該当フォームがloadされていなければOpenする。

    If CurrentProject.AllForms("f_履歴一覧").IsLoaded Then
        Forms![f_履歴一覧].Visible = True
    Else
        DoCmd.OpenForm "f_履歴一覧"
    End If

    Forms![f_履歴一覧].Requery