'Const fil1 As String = "C:\Program Files\MSPAINT.EXE"
Const fil1 As String = "C:\WINDOWS\PBRUSH.EXE"
Const dv As String = "C:"      '保存先ドライブ
Const dr As String = "\test2"  '保存先ディレクトリ−

Dim fil2 As String
Dim filn As String   'BMPのファイル名
Dim n As Integer     'BMPのファイル名no
        
Sub ki263()
'BMPのファイル名
      n = n + 1
      filn = "画像" & Str(n)
'画像コピ−
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
  Application.WindowState = xlMinimized
'Notepadの起動と保存画面表示

    ChDrive dv
    ChDir dr
    fil2 = dv & dr
     On Error Resume Next
     AppActivate "ペイント"
     If Err Then
       Shell fil1 + " ", windowstyle:=1
     End If
     On Error GoTo 0
'過去のファイル削除
      If Dir(fil2 & "\" & filn & ".bmp") = filn & ".bmp" Then
           Kill fil2 & "\" & filn & ".bmp"
      End If
      If Dir(fil2 & "\無題.bmp") = "無題.bmp" Then
           Kill fil2 & "\無題.bmp"
      End If
      tim = Now + TimeValue("00:00:08")
Do
'保存
    SendKeys "%(FA)", True           '名前を付け保存
    SendKeys "%(S)", True            '保存

    If Dir(fil2 & "\無題.bmp") = "無題.bmp" Then
           Kill fil2 & "\無題.bmp"
           Exit Do
    End If
    If Now > tim Then
       MsgBox "変換に失敗しました。ペイントのパスを確認して下さい"
       Exit Sub
    End If
Loop

'貼付け
      SendKeys "%(EP)", True
'保存
    SendKeys "%(EO)", True          'ファイルへコピ−
    SendKeys filn, True
    SendKeys "%(S)", True            'OK
    

    Application.CutCopyMode = False
'終了
    SendKeys "%(FX)", True           'ペイント終了
    SendKeys "(N)", True
    Application.WindowState = xlNormal
    MsgBox fil2 & "へ" & filn & ".bmp 名で保存しました"
    
End Sub