anonymous No title
VBA
’ブックモジュールに記述

Option Explicit


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim shpCat          As Shape        '動作する画像
    Dim shpAroundRng    As Range        'ShpCatの配置されているセル範囲
    Dim appearRng       As Range        'ShpCatが出現するセル
    Dim activeRng       As Range        'ActiveCellを保持するための変数
    Dim SelectRng       As Range        'Selectionを保持するための変数
    Dim visiRng         As Range        '現在画面に表示されているセル範囲
    
    Set visiRng = ActiveWindow.VisibleRange
    Set activeRng = ActiveCell
    Set SelectRng = Selection
    
    
    Application.EnableEvents = False
    
    Set shpCat = getShp(shpName:="cat")
    Call delShp(shpName:="テキスト")
    
    If Not shpCat Is Nothing Then
        
        Set shpAroundRng = shpCat.Parent.Range(shpCat.TopLeftCell, shpCat.BottomRightCell)
        Set appearRng = getAppearRng(visiRng)
        Select Case True
            Case shpCat.Parent.Name <> Sh.Name, Intersect(visiRng, shpAroundRng) Is Nothing '画面内にShpCatが無ければ、shpCatをカットしappearRngに貼り付ける
                shpCat.Cut
                appearRng.Select
                Sh.Paste
                Set shpCat = Sh.Shapes(Selection.Name)
                Target.Select
        End Select
        
        
        Call 猫寄ってくる(activeRng, shpCat)
        
    End If
    
    SelectRng.Select
    Application.EnableEvents = True
    
End Sub


Private Function getShp(ByVal shpName As String) As Shape
    '名前がShpNameのShapeがSetされ次第関数を抜ける
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        Set getShp = ws.Shapes(shpName)
        If Err.Number = 0 Then Exit For
        Err.Clear
    Next

End Function

Private Sub delShp(ByVal shpName As String)
    'ブック内の全てのShpNameのShapeを削除する
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        ws.Shapes(shpName).Delete
    Next

End Sub

Private Function getAppearRng(ByVal rng As Range) As Range
    '引数rngの四隅(の一つ内側)のセルの内いずれかをランダムで返す関数
    '1:左上
    '2:右上
    '3:左下
    '4:右下
    
    Randomize
    Dim rndNum As Long
    rndNum = Int(Rnd * 4) + 1
    
    Select Case rndNum
        Case 1:     Set getAppearRng = rng(1).Offset(1, 1)
        Case 2:     Set getAppearRng = rng.Offset(, rng.Columns.Count - 1).Item(1).Offset(1, -1)
        Case 3:     Set getAppearRng = rng.Offset(rng.Rows.Count - 1).Item(1).Offset(-1, 1)
        Case 4:     Set getAppearRng = rng(rng.Count).Offset(-1, -1)
    End Select
        
    
End Function


Private Sub 猫寄ってくる(ByVal rng As Range, ByVal shp As Shape)
    'shpの縦位置がrngの縦位置に達するまで縦移動し続ける
    'shpの横位置がrngの横位置に達するまで横移動し続ける
    'shpとrngの位置が一致したらループを抜ける
    
    Dim sphCenterV      As Double   'shpの縦中央位置
    Dim sphCenterH      As Double   'shpの横中央位置
    Dim rngCenterV      As Double   'rngの縦中央位置
    Dim rngCenterH      As Double   'rngの横中央位置
    Dim beforeShpArea   As String   'shpの1ステップ移動前位置
    Dim afterShpArea    As String   'shpの1ステップ移動後位置
    Dim flgV            As Boolean  'shpの縦位置がrngの縦位置に達したらTrueにする
    Dim flgH            As Boolean  'shpの横位置がrngの横位置に達したらTrueにする
    Const speed As Double = 6
    
    rngCenterV = rng.Top + rng.Height / 2
    rngCenterH = rng.Left + rng.Width / 2
    
    Do
        DoEvents
        
        sphCenterV = shp.Top + shp.Height / 2
        sphCenterH = shp.Left + shp.Width / 2
        
        beforeShpArea = shp.Top & "|" & shp.Left
        If Not flgV Then shp.Top = IIf(sphCenterV - rngCenterV < 0, shp.Top + speed, shp.Top - speed)
        If Not flgH Then shp.Left = IIf(sphCenterH - rngCenterH < 0, shp.Left + speed, shp.Left - speed)
        afterShpArea = shp.Top & "|" & shp.Left
        
        
        If Abs(sphCenterV - rngCenterV) < speed Then flgV = True
        If Abs(sphCenterH - rngCenterH) < speed Then flgH = True
        
        If flgV And flgH Then Exit Do
        If afterShpArea = beforeShpArea Then Exit Do
        
        Application.Wait [Now()] + 0.001 / 86400
    Loop
    
    
    Call にゃーと鳴く(shp, shp.Parent)
    
    
    
End Sub



Private Sub にゃーと鳴く(ByVal shp As Shape, ByVal ws As Worksheet)
    'shpの右隣にテキストボックスを配置して「にゃーー」と入力するにゃ。
    
    Dim テキストTop     As Double
    Dim テキストleft    As Double
    Dim テキスト        As Shape
    
    テキストTop = shp.Top
    テキストleft = shp.Left + shp.Width

    ws.Shapes.AddTextbox( _
            Orientation:=msoTextOrientationHorizontal, _
            Left:=テキストleft, _
            Top:=テキストTop, _
            Width:=100, _
            Height:=60).Select
    
    With Selection
        .Name = "テキスト"
        .ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
        .ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.Fill.ForeColor.RGB = 11854022
        .ShapeRange.Line.ForeColor.RGB = 0
        .ShapeRange.TextFrame.Characters.Text = "にゃーー"
        .ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
        .ShapeRange.TextFrame2.TextRange.Font.Size = 16
    End With
    
End Sub


anonymous No title
VBA
'ブックモジュールに記述

Option Explicit


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim shpCat          As Shape        '動作する画像
    Dim shpAroundRng    As Range        'ShpCatの配置されているセル範囲
    Dim appearRng       As Range        'ShpCatが出現するセル
    Dim activeRng       As Range        'ActiveCellを保持するための変数
    Dim visiRng         As Range        '現在画面に表示されているセル範囲
    Set visiRng = ActiveWindow.VisibleRange
    Set activeRng = ActiveCell
    
    Application.EnableEvents = False
    
    Set shpCat = getShp(shpName:="cat")
    Call delShp(shpName:="テキスト")
    
    If Not shpCat Is Nothing Then
        
        Set shpAroundRng = shpCat.Parent.Range(shpCat.TopLeftCell, shpCat.BottomRightCell)
        Set appearRng = getAppearRng(visiRng)
        Select Case True
            Case shpCat.Parent.Name <> Sh.Name, Intersect(visiRng, shpAroundRng) Is Nothing '画面内にShpCatが無ければ、shpCatをカットしappearRngに貼り付ける
                shpCat.Cut
                appearRng.Select
                Sh.Paste
                Set shpCat = Sh.Shapes(Selection.Name)
                Target.Select
        End Select
        
        
        Call 猫寄ってくる(activeRng, shpCat)
        
    End If
    
    activeRng.Select
    Application.EnableEvents = True
    
End Sub


Private Function getShp(ByVal shpName As String) As Shape
    '名前がShpNameのShapeがSetされ次第関数を抜ける
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        Set getShp = ws.Shapes(shpName)
        If Err.Number = 0 Then Exit For
        Err.Clear
    Next

End Function

Private Sub delShp(ByVal shpName As String)
    'ブック内の全てのShpNameのShapeを削除する
    
    Dim ws          As Worksheet
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        ws.Shapes(shpName).Delete
    Next

End Sub

Private Function getAppearRng(ByVal rng As Range) As Range
    '引数rngの四隅(の一つ内側)のセルの内いずれかをランダムで返す関数
    '1:左上
    '2:右上
    '3:左下
    '4:右下
    
    Randomize
    Dim rndNum As Long
    rndNum = Int(Rnd * 4) + 1
    
    Select Case rndNum
        Case 1:     Set getAppearRng = rng(1).Offset(1, 1)
        Case 2:     Set getAppearRng = rng.Offset(, rng.Columns.Count - 1).Item(1).Offset(1, -1)
        Case 3:     Set getAppearRng = rng.Offset(rng.Rows.Count - 1).Item(1).Offset(-1, 1)
        Case 4:     Set getAppearRng = rng(rng.Count).Offset(-1, -1)
    End Select
        
    
End Function


Private Sub 猫寄ってくる(ByVal rng As Range, ByVal shp As Shape)
    'shpの縦位置がrngの縦位置に達するまで縦移動し続ける
    'shpの横位置がrngの横位置に達するまで横移動し続ける
    'shpとrngの位置が一致したらループを抜ける
    
    Dim sphCenterV      As Double   'shpの縦中央位置
    Dim sphCenterH      As Double   'shpの横中央位置
    Dim rngCenterV      As Double   'rngの縦中央位置
    Dim rngCenterH      As Double   'rngの横中央位置
    Dim beforeShpArea   As String   'shpの1ステップ移動前位置
    Dim afterShpArea    As String   'shpの1ステップ移動後位置
    Dim flgV            As Boolean  'shpの縦位置がrngの縦位置に達したらTrueにする
    Dim flgH            As Boolean  'shpの横位置がrngの横位置に達したらTrueにする
    Const speed As Double = 6
    
    rngCenterV = rng.Top + rng.Height / 2
    rngCenterH = rng.Left + rng.Width / 2
    
    Do
        DoEvents
        
        sphCenterV = shp.Top + shp.Height / 2
        sphCenterH = shp.Left + shp.Width / 2
        
        beforeShpArea = shp.Top & "|" & shp.Left
        If Not flgV Then shp.Top = IIf(sphCenterV - rngCenterV < 0, shp.Top + speed, shp.Top - speed)
        If Not flgH Then shp.Left = IIf(sphCenterH - rngCenterH < 0, shp.Left + speed, shp.Left - speed)
        afterShpArea = shp.Top & "|" & shp.Left
        
        
        If Abs(sphCenterV - rngCenterV) < speed Then flgV = True
        If Abs(sphCenterH - rngCenterH) < speed Then flgH = True
        
        If flgV And flgH Then Exit Do
        If afterShpArea = beforeShpArea Then Exit Do
        
        Application.Wait [Now()] + 0.001 / 86400
    Loop
    
    
    Call にゃーと鳴く(shp, shp.Parent)
    
    
    
End Sub



Private Sub にゃーと鳴く(ByVal shp As Shape, ByVal ws As Worksheet)
    'shpの右隣にテキストボックスを配置して「にゃーー」と入力するにゃ。
    
    Dim テキストTop     As Double
    Dim テキストleft    As Double
    Dim テキスト        As Shape
    
    テキストTop = shp.Top
    テキストleft = shp.Left + shp.Width

    ws.Shapes.AddTextbox( _
            Orientation:=msoTextOrientationHorizontal, _
            Left:=テキストleft, _
            Top:=テキストTop, _
            Width:=100, _
            Height:=60).Select
    
    With Selection
        .Name = "テキスト"
        .ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
        .ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.Fill.ForeColor.RGB = 11854022
        .ShapeRange.Line.ForeColor.RGB = 0
        .ShapeRange.TextFrame.Characters.Text = "にゃーー"
        .ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
        .ShapeRange.TextFrame2.TextRange.Font.Size = 16
    End With
    
End Sub


anonymous No title
VBA
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
anonymous No title
VBA
'ブックモジュール
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
anonymous No title
VBA
'ブックモジュール
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

anonymous No title
VBA
'ブックモジュール
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

anonymous No title
VBA
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
anonymous No title
VBA
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
tomo hata@就職活動中 Excelファイル一括オープン
VBA
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

anonymous No title
VBA
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
Don't you submit code?
Submit