Option Explicit

Sub タイムスタンプ修正(targetFile_FullPath As String)

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim FO As Object
    
    'ファイルの存在確認
    If Not FSO.FileExists(targetFile_FullPath) Then
        MsgBox targetFile_FullPath & "が存在しません。", vbCritical + vbOKOnly
        GoTo finally
    End If
    
    Set FO = FSO.GetFile(targetFile_FullPath)
    
    'ファイルタイプチェック ※言語設定やOSバージョンによってどうなる？？
    If Not FO.Type = "JPG ファイル" Then
        MsgBox "ファイルタイプが処理対象(JPG ファイル)とは異なります。", vbCritical + vbOKOnly
        GoTo finally
    End If
    '拡張子チェック ※文字列だけなのでざる
    'If Not StrConv(targetFile_FullPath, vbNarrow + vbUpperCase) Like "*JPG" Then
    '    MsgBox "拡張子が処理対象(*.jpg)とは異なります。", vbCritical + vbOKOnly
    '    GoTo finally
    'End If
    
    Dim dateModify As Date
    dateModify = getExifDTOrig(targetFile_FullPath)
    
    If dateModify = 0 Then
        MsgBox "画像ファイルから撮影日時を取得できませんでした。" & vbCrLf & "処理を中断します。", vbCritical + vbOKOnly
        Exit Sub
    End If
    
    If MsgBox("指定ファイル[" & targetFile_FullPath & "]の" & vbCrLf _
            & "タイムスタンプを変更しますがよろしいでしょうか？" & vbCrLf _
            & vbCrLf _
            & "現作成日：" & Format(FO.DateCreated, "yyyy/mm/dd hh:mm:ss") & vbCrLf _
            & "現更新日：" & Format(FO.DateLastModified, "yyyy/mm/dd hh:mm:ss") & vbCrLf _
            & "変 更 値：" & Format(dateModify, "yyyy/mm/dd hh:mm:ss"), vbQuestion + vbYesNo) = vbNo Then
            
            GoTo finally
    End If
    
    Dim pCmd As String
    
    '作成日時変更
    pCmd = "Set-ItemProperty '" & targetFile_FullPath & "' -Name CreationTime -Value '" & Format(dateModify, "yyyy/mm/dd hh:mm:ss") & "'"
    Call runPowerShell(pCmd)
    
    '更新日時変更
    pCmd = "Set-ItemProperty '" & targetFile_FullPath & "' -Name LastWriteTime -Value '" & Format(dateModify, "yyyy/mm/dd hh:mm:ss") & "'"
    Call runPowerShell(pCmd)
    
    MsgBox "更新完了", vbInformation + vbOKOnly


'共通終了処理
finally:
    
    Set FO = Nothing
    Set FSO = Nothing

End Sub

Sub runPowerShell(pCmd)

    Dim WSH, wExec, sCmd As String
    Set WSH = CreateObject("WScript.Shell")
    
    sCmd = "powershell -ExecutionPolicy RemoteSigned -Command """ & pCmd & """"
    WSH.Run sCmd, 0, True
    
    Set WSH = Nothing

End Sub

Function getExifDTOrig(jpgFile_FullPath As String) As Date

    Dim WIA As Object
    Set WIA = CreateObject("Wia.ImageFile")
    
    On Error GoTo catch
    
    WIA.LoadFile jpgFile_FullPath
    
    'Exif情報にExifDTOrigがあるか確認
    Dim prop
    For Each prop In WIA.Properties
        If prop.Name = "ExifDTOrig" Then
            GoTo hasExifDTOrig
        End If
    Next prop
    
    getExifDTOrig = 0
    
    GoTo finally
    
'hasExifDTOrigがあった場合の処理
hasExifDTOrig:
    
    On Error GoTo 0
    
    Dim StrDate As String
    StrDate = Replace(WIA.Properties("ExifDTOrig").Value, ":", "/", 1, 2, vbTextCompare)
    
    If IsDate(StrDate) Then
        getExifDTOrig = CDate(StrDate)
    Else
        getExifDTOrig = 0
    End If
    
    GoTo finally

'何かしらのエラーがあった場合（不正データによる参照エラーなど）
catch:

    'Debug.Print "[ERROR][getExifDTOrig] " & Err.Description
    getExifDTOrig = 0

'共通終了処理
finally:

    Set WIA = Nothing

End Function

Option Explicit

Enum FileCompareResult
    一致 = 0
    不一致 = 1
    エラー = 2
End Enum

Sub ファイル比較(fileA As String, fileB As String)
    
    Dim Result As FileCompareResult
    Result = fileCompare(fileA, fileB)
    
    Select Case Result
    Case FileCompareResult.一致
        MsgBox "ファイルは一致しています。", vbInformation + vbOKOnly
    Case FileCompareResult.不一致
        MsgBox "ファイルは一致していません。", vbInformation + vbOKOnly
    Case FileCompareResult.エラー
        MsgBox "比較中にエラーが発生しました。（ファイルが存在していないなど）", vbCritical + vbOKOnly
    End Select
    
End Sub

Function fileCompare(fileA_FullPath As String, fileB_FullPath As String) As FileCompareResult

    '★WSH実行のベースはOffice TANAKAさん
    'MS-DOSコマンドの標準出力を取得する
    'http://officetanaka.net/excel/vba/tips/tips27.htm

    Dim WSH, wExec, sCmd As String
    Set WSH = CreateObject("WScript.Shell")
    
    'コマンド実行 comp /M …ファイルの比較、/Mは次ファイルの対話的確認を省略
    sCmd = "comp /M """ & fileA_FullPath & """ """ & fileB_FullPath & """"
    Set wExec = WSH.Exec("%ComSpec% /c " & sCmd)
    
    '実行完了待機
    Do While wExec.Status = 0
        DoEvents
    Loop
    
    '実行時標準出力取得
    Dim ResultStdOut As String
    ResultStdOut = wExec.StdOut.ReadAll
    
    '結果判定
    If ResultStdOut Like "*ファイルに違いはありません*" Then
        fileCompare = FileCompareResult.一致
    ElseIf ResultStdOut Like "*ファイルのサイズが違います*" _
            Or ResultStdOut Like "*比較エラーがあります*" Then
        fileCompare = FileCompareResult.不一致
    Else
        fileCompare = FileCompareResult.エラー
    End If
        
    Set wExec = Nothing
    Set WSH = Nothing
    
    
    '★想定しているcompコマンドの結果
    '>comp /M "C:\temp\fileCompare\AkihabaraKousaten.jpg" "C:\temp\fileCompare\AkihabaraKousaten.jpg"
    'C:\temp\fileCompare\AkihabaraKousaten.jpg と C:\temp\fileCompare\AkihabaraKousaten.jpg を比較しています...
    'ファイルに違いはありません
    '>echo %ERRORLEVEL%
    '0
    '
    '>comp /M "C:\temp\fileCompare\JrOchanomizuEki.jpg" "C:\temp\fileCompare\AkihabaraKousaten.jpg"
    'C:\temp\fileCompare\JrOchanomizuEki.jpg と C:\temp\fileCompare\AkihabaraKousaten.jpg を比較しています...
    'ファイルのサイズが違います｡
    '>echo %ERRORLEVEL%
    '1
    '
    '>comp /M "C:\temp\fileCompare\JrOchanomizuEki.jpg" "C:\temp\fileCompare\JrOchanomizuEki_binarryMod.jpg"
    'C:\temp\fileCompare\JrOchanomizuEki.jpg と C:\temp\fileCompare\JrOchanomizuEki_binarryMod.jpg を比較しています...
    'OFFSET 2000 で比較エラーがあります
    'ファイル1 = 32
    'ファイル2 = 23
    '
    '>echo %ERRORLEVEL%
    '1
    '
    '>comp /M "C:\temp\fileCompare\AkihabaraKousaten.jpg" "C:\temp\fileCompare\AkihabaraKousaten.jp"
    'C:\temp\fileCompare\AkihabaraKousaten.jpg と C:\temp\fileCompare\AkihabaraKousaten.jp を比較しています...
    'ファイルが見つからないか、開けません: C:\temp\fileCompare\AkihabaraKousaten.jp
    '
    '>echo %ERRORLEVEL%
    '2

End Function

Option Explicit
Sub フォルダ内エクセルファイル一括オープン()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim wb As Workbook, cnt As Long, wind As Window
    Dim myFolder As Folder, myFile As File
    Set myFolder = FSO.GetFolder(ThisWorkbook.Path)
    On Error GoTo myError
    '各ファイルの拡張子を確認してエクセルファイルを判別
    For Each myFile In myFolder.Files
        If myFile.Path Like "*.xls*" Then
            cnt = 0
            For Each wb In Workbooks
                cnt = cnt + 1
                '指定のファイルが既に開いていた場合
                If myFile.Name = wb.Name Then
                    'このブックの場合は何もしない
                    If wb.Name = ThisWorkbook.Name Then
                        Exit For
                    'このブック以外の場合
                    Else
                        MsgBox myFile.Path & "は既に開いています", vbInformation
                        Exit For
                    End If
                '最後のファイルまで確認してファイル名が"~$*"でなければブックを開く
                ElseIf (cnt = Workbooks.Count) And (Not myFile.Name Like "~$*") Then
                    Workbooks.Open myFile
                    Exit For
                End If
            Next
        End If
    Next
    '各ウインドウが最大化されていなければ最大化する
    For Each wind In Windows
        With Application
            If Not .WindowState = xlMaximized Then .WindowState = xlMaximized
        End With
    Next
    Set myFolder = Nothing
    Set myFile = Nothing
    ThisWorkbook.Close
    Exit Sub
myError:
    Debug.Print Err.Number & vbCrLf & Err.Description
    Resume Next
End Sub

Sub a()
    Dim oT As Outlook.Table
    Dim strFilter As String
    Dim oRow As Outlook.Row
    Dim oItem As Outlook.MailItem

    On Error Resume Next

    strFilter = ""
    Set oT = Application.Session.GetDefaultFolder(olFolderInbox).GetTable(strFilter)
    Do Until oT.EndOfTable
      Set oRow = oT.GetNextRow
      Set oItem = Application.Session.GetItemFromID(oRow("EntryID"))
      Debug.Print oRow("Subject"); "Attachments.Count=" & oItem.Attachments.Count
      Dim at As Attachment
      For Each at In oItem.Attachments
        Debug.Print at
        If InStr(at, ".") > 0 Then
          at.SaveAsFile ("D:\ss\" & at.FileName)
        End If
      Next
    Loop
End Sub

Sub a()
    Dim oT As Outlook.Table
    Dim strFilter As String
    Dim oRow As Outlook.Row
    Dim oItem As Outlook.MailItem

    On Error Resume Next

    strFilter = ""
    Set oT = Application.Session.GetDefaultFolder(olFolderInbox).GetTable(strFilter)
    Do Until oT.EndOfTable
      Set oRow = oT.GetNextRow
      Set oItem = Application.Session.GetItemFromID(oRow("EntryID"))
      Debug.Print oRow("Subject"); "Attachments.Count=" & oItem.Attachments.Count
    Loop
End Sub

Attribute VB_Name = "DataCount"
Option Explicit

Sub test()
    'test�����p�v���V�[�W��
    '�T���v��������o�^

    Dim a As Worksheet: Set a = ThisWorkbook.Worksheets("�O���t")
    Dim b As Worksheet: Set b = ThisWorkbook.Worksheets("�W�v����")
    Dim c As Variant: Set c = CreateObject("scripting.dictionary")
    Dim d As String: d = "I"
    Dim e As Range: Set e = Range("B5")
    
    Call MyDictionaryMain(a, b, c, d, e)

    Set a = Nothing
    Set b = Nothing
    Set c = Nothing
    Set e = Nothing
    
End Sub

Public Sub MyDictionaryMain(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range
    
    '�W�v�R���g�[���v���V�[�W��
    Call MyDictionary(TargetWs, TargetWs2, TargetMyDic, TargetKey, TargetRng)

    Call OutputDic(TargetWs, TargetWs2, TargetMyDic, TargetKey, TargetRng)

End Sub

Private Sub MyDictionary(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range

    '�e���ڂ̍��v���擾�i�A�z�z������鎖�ɂ��ȒP�ɏo����j
    Dim i As Long, j As Long
    
    '�\���֖ؑ���
    Application.ScreenUpdating = False

    TargetWs.Cells.ClearContents '�\����x�N���A

    '�\�̍ŏI�s���擾
    Dim lastRow As Long: lastRow = TargetWs2.Cells(Rows.Count, TargetKey).End(xlUp).Row
    
    '�\�̂��ׂĂ������ɓo�^
    For i = 5 To lastRow  '�f�[�^�J�n�s5�s�`�ŏI�s�܂�
        
        If TargetMyDic.Exists(TargetWs2.Cells(i, TargetKey).Value) Then        '�L�[�̑��݊m�F
            '�L�[�̓o�^������ꍇ�́A����(myDic(Cells(i,1).value)�˂���́A�A�z�z��ł���A�l�������Ă���
            TargetMyDic(TargetWs2.Cells(i, TargetKey).Value) = TargetMyDic(TargetWs2.Cells(i, TargetKey).Value) + 1
        Else
            TargetMyDic.Add TargetWs2.Cells(i, TargetKey).Value, 1     '�L�[�̓o�^�������ꍇ�́A�lj�����
        End If
    Next
                    
End Sub

Private Sub OutputDic(TargetWs As Worksheet, TargetWs2 As Worksheet, TargetMyDic As Variant, TargetKey As String, TargetRng As Range)
    '��P�����F�]�L�惏�[�N�V�[�g�I�u�W�F�N�g
    '��Q�����F�]�L�����[�N�V�[�g�I�u�W�F�N�g
    '��R�����F�W�v���ʔz��
    '��S�����F�W�v�p�L�[��
    '��T�����F�]�L��Range
   
    '�A�z�z��̏����o��
    Dim OutputArr: Dim OutputKey
    ReDim OutputArr(TargetMyDic.Count - 1, 1)
        
    Dim j: j = 0

    'MyDictionary�Ŏ擾�������e��Outout�p�z��ɑ��
    For Each OutputKey In TargetMyDic
        OutputArr(j, 0) = OutputKey
        OutputArr(j, 1) = TargetMyDic.Item(OutputKey)
        j = j + 1
    Next
    
    Dim lastRow As Long: lastRow = TargetMyDic.Count            '�z��̍ŏI�s��(�傫��)
    
    '�]�L��A�h���X
    
    TargetWs.TargetRng.Resize(lastRow, 2) = OutputArr
    
    '�\���֖ؑ���
    Application.ScreenUpdating = True
 
 End Sub

Option Explicit

main

sub main()
    Dim path
    Dim fileName

    On Error Resume Next
    'ドラッグ＆ドロップされたファイルのパス
    path = WScript.Arguments(0)
    'ダブルクリックでオープンされた場合、自身のフルパスを返す
    If Err Then path = WScript.ScriptFullName
    On Error Goto 0

    'ファイル名とフルパスを表示
    fileName = Mid(path, InStrRev(path, "\") + 1, Len(path) - InStrRev(path, "\"))
    InputBox fileName & "のフルパス", "フルパス取得", path 
end sub

 sub test()
 
    activeworkbook.slicercache.add2(activesheet.listobjects("テーブル１")."申請者")._
        slicers.add activesheet,,"申請者","申請者",240,450,150,210

end sub

Sub 別シートセルの値を習得してシート繰り返しコピー()

'シートセレクト
Sheets("データベース").Select

Dim i 'ループカウンタ
Dim s 'セル値



'A4セルをアクティブ
Range("A4").Select

'ループカウンタ初期化
i = 0

'空セルまでループ
Do
  'セルの値を取得
  s = ActiveCell.Offset(i, 0).Value
  
  
  'セルのr隊が未設定の場合
  If s = "" Then
  
   'ループ抜ける
   Exit Do
 End If
'ループカウンタ加算
i = i + 1

MsgBox i '習得値確認

'シートひな形1をコピー
Worksheets("ひな形1").Copy after:=ActiveSheet

Range("AK25").Value = i

'シートひな形2コピー
ActiveSheet.Name = ActiveSheet.Range("V4")
Worksheets("ひな形2").Copy after:=ActiveSheet

ActiveSheet.Name = ActiveSheet.Range("I3") & "桝設置"

Loop

End Sub


Function RefLeftSheet(objCell As Range) As Variant
'左隣のシートのセル参照マクロ
  
  Application.Volatile
  
  RefLeftSheet = objCell.Parent.Previous.Range(objCell.Address).Value

End Function