Option Explicit

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
     Source As Any, _
     ByVal Length As LongPtr)
Sub test()
    
    Dim strA As String
    Dim strB As String
    Dim btA(3) As Byte
    Dim btB(3) As Byte
    Dim i As Long
    
    strA = "AAAAAAAAAAAAAAAA"
    
    'VarPtr(strA)とはstrAの文字列の実体が置かれているアドレスが書かれているアドレス。
    '以下を実施することでstrBの文字列の実体が置かれているアドレスが書かれているアドレスに
    'strAの実体が置かれているアドレスが書き込まれる。
    Call CopyMemory(ByVal VarPtr(strB), ByVal VarPtr(strA), 4)
    
    'Midステートメントの実施
    Mid(strA, 3, 2) = "BB"
        
    'strAに変更を加えたのにstrBにも影響が
    Debug.Print "両者の文字列を表示"
    Debug.Print strA
    Debug.Print strB
    
    '文字列の実体が書かれているアドレスを取得
    Call CopyMemory(btA(0), ByVal VarPtr(strA), 4)
    Call CopyMemory(btB(0), ByVal VarPtr(strB), 4)
    
    '同じ文字列の実体を指し示している2つの変数なのでstrBにも影響が出るのは当然
    'Midステートメントは文字列の実体を操作しているだけと想像できる
    Debug.Print vbCr & "両者の文字列の実体のアドレス"
    For i = 0 To 3
        Debug.Print Hex(btA(i)) & " ";
    Next i
    Debug.Print ""
    For i = 0 To 3
        Debug.Print Hex(btB(i)) & " ";
    Next i
    Debug.Print ""
    
    'Midステートメントのやっていることを想像
    '3文字目は先頭アドレス＋4バイト目（1文字目0バイト1バイト、2文字目2バイト3バイト）
    'どこかに用意した"BB"のアドレスから2文字（4バイト分）
    'Call CopyMemory(ByVal StrPtr(strA) + 4, ByVal StrPtr("BB"), 4)
    '↑Midステートメントの代わりにMidステートメントと同じ場所で実施すれば同じ結果となる
    
    'Replace
    strA = Replace(strA, "BB", "CC")
    
    '今度はstrBには影響しない
    Debug.Print vbCr & "両者の文字列を表示"
    Debug.Print strA
    Debug.Print strB
    
    '文字列の実体が書かれているアドレスを取得
    Call CopyMemory(btA(0), ByVal VarPtr(strA), 4)
    Call CopyMemory(btB(0), ByVal VarPtr(strB), 4)
    
    '違う文字列の実体を指し示している。
    'Replaceのコードを見れば、strAに代入してしまったので別の文字列の実体を指し示すようになったということ。
    Debug.Print vbCr & "両者の文字列の実体のアドレス"
    For i = 0 To 3
        Debug.Print Hex(btA(i)) & " ";
    Next i
    Debug.Print ""
    For i = 0 To 3
        Debug.Print Hex(btB(i)) & " ";
    Next i
    Debug.Print ""
    
    '文字数を取得（文字列の実体より前4バイトで文字数を表す）
    Dim btC(3) As Byte
    Call CopyMemory(btC(0), ByVal StrPtr(strA) - 4, 4)
    
    'リトルエンディアンで20＝32バイト＝16文字と分かる
    Debug.Print vbCr & "strAの文字数を取得"
    For i = 0 To 3
        Debug.Print Hex(btC(i)) & " ";
    Next i
    Debug.Print ""
    
    'こんなことしちゃって良いの？
    '文字数変更で8文字（16バイト)
    btC(0) = 16
    Call CopyMemory(ByVal StrPtr(strA) - 4, btC(0), 4)
    
    Debug.Print vbCr & "8文字に変更したstrAの表示"
    Debug.Print strA
    
    '終端が00じゃ無いんですけど！！（16バイト目が00になっていない）
    Dim btD(31) As Byte
    Call CopyMemory(btD(0), ByVal StrPtr(strA), 32)
    Debug.Print vbCr & "strAの8文字とstrAより後の8文字を表示"
    Debug.Print btD
    Debug.Print "↑strAの終端が00じゃ無いんですけど！！"
    
End Sub

'ブックモジュール
Option Explicit

Private Sub Workbook_Open()
    Application.OnKey "+^{c}", "inTotal"
    Application.OnKey "+^{+}", "plusTotal"
    Application.OnKey "+^{v}", "outTotal"
    Application.OnKey "+^{*}", "clearTotal"
End Sub


'標準モジュール
Option Explicit

Dim stackSum As Variant

Sub inTotal()
    stackSum = CDec(WorksheetFunction.Sum(Selection))
    Call showStatusBer(stackSum)
End Sub

Sub plusTotal()
    stackSum = stackSum + CDec(WorksheetFunction.Sum(Selection))
    Call showStatusBer(stackSum)
End Sub


Sub outTotal()
    Selection.Value = stackSum
End Sub

Sub clearTotal()
    stackSum = 0
    Application.StatusBar = False
End Sub

Sub showStatusBer(ByVal num As Variant)
    Dim len小数部 As Long:  len小数部 = Len(CStr(num)) - Len(CStr(Int(num))) - 1
    
    If len小数部 <= 0 Then
        Application.StatusBar = "Total = " & Format(num, "#,##0")
    Else
        Application.StatusBar = "Total = " & Format(num, "#,##0." & String(len小数部, "0"))
    End If

End Sub

'ブックモジュール
Option Explicit

Private Sub Workbook_Open()
    Application.OnKey "+^{c}", "inTotal"
    Application.OnKey "+^{+}", "plusTotal"
    Application.OnKey "+^{v}", "outTotal"
    Application.OnKey "+^{*}", "clearTotal"
End Sub

'標準モジュール
Option Explicit

Dim stackSum As Double

Sub inTotal()
    stackSum = WorksheetFunction.Sum(Selection)
    Application.StatusBar = "stackSum = " & Format(stackSum, "#,##0")
End Sub

Sub plusTotal()
    stackSum = stackSum + WorksheetFunction.Sum(Selection)
    Application.StatusBar = "stackSum = " & Format(stackSum, "#,##0")
End Sub


Sub outTotal()
    Selection.Value = stackSum
End Sub

Sub clearTotal()
    stackSum = 0
    Application.StatusBar = False
End Sub

'ブックモジュール
Option Explicit

Private Sub Workbook_Open()
    Application.OnKey "+^{c}", "inTotal"
    Application.OnKey "+^{+}", "plusTotal"
    Application.OnKey "+^{v}", "outTotal"
    Application.OnKey "+^{*}", "clearTotal"
End Sub



'標準モジュール
Option Explicit

Dim stackSum As Long

Sub inTotal()
    stackSum = WorksheetFunction.Sum(Selection)
    Application.StatusBar = "stackSum = " & Format(stackSum, "#,##0")
End Sub

Sub plusTotal()
    stackSum = stackSum + WorksheetFunction.Sum(Selection)
    Application.StatusBar = "stackSum = " & Format(stackSum, "#,##0")
End Sub


Sub outTotal()
    Selection.Value = stackSum
End Sub

Sub clearTotal()
    stackSum = 0
    Application.StatusBar = False
End Sub

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