【マクロ】スクショ印刷がうまく動かない件

Question

タイトルの件、下記のマクロ【コールステイトメント】をご覧ください。
同マクロが

●添付画像１の場合
⇒白紙のエクセルの場合は動く

●添付画像２の場合
⇒エクセル上にマクロボタンを付けた場合
⇒動かない

です。

解決方法をご存じの方は教えて下さい。

【エラー内容】
下記がデバックとなります。トリミングのマクロです。
.PictureFormat.CropTop = OffTop


【マクロ　コールステイトメント内容】
Sub コール()

'プリントスクリーンボタンを押し、スクショを取って、エクセルに貼付する
Call スクショ貼付

'撮ったスクショを、自由なサイズにトリミングする
Call トリミング

'トリミングしたスクショを、自由なサイズに変更する
Call サイズ調整

'変更したサイズを印刷する
Call 印刷

End Sub

４つのマクロのコードです↓↓↓

【スクショ貼付】
'キーボードイベント用のライブラリ読み込み
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, _
    ByVal bScan As Byte, _
    ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long _
    )

Sub スクショ貼付()
    keybd_event vbKeySnapshot, 0&, fKEYDOWN, 0&
    
    keybd_event vbKeySnapshot, 0&, fKEYUP, 0&
    
    Application.Wait Now() + TimeValue("00:00:01")
    
    Range("A1").Select
    
    ActiveSheet.Paste
    
    Selection.Copy
    
    

    
End Sub

【トリミング】
Sub トリミング()
    Const OffTop As Double = 0 '上の切り取り
    Const OffLeft As Double = 0 '左の切り取り
    Const OffBottom As Double = 0 '下の切り取り
    Const OffRight As Double = 500 '右の切り取り
    Dim ws As Worksheet
    Dim sp1 As Shape
    Set ws = ActiveSheet
    Set sp1 = ws.Shapes(1)
    With sp1
        .PictureFormat.CropTop = OffTop
        .PictureFormat.CropLeft = OffLeft
        .PictureFormat.CropBottom = OffBottom
        .PictureFormat.CropRight = OffRight
    End With
End Sub

【サイズ調整】
Sub サイズ調整()
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes(1)

    With shp
        .LockAspectRatio = msoFalse
        .Height = ActiveSheet.Range("1:30").Height
        .Width = ActiveSheet.Range("a:ao").Width
    End With
End Sub



【印刷】
Sub 印刷()
    
    Worksheets("ボタンなし").PrintOut

End Sub

Qchan1962 · Accepted Answer

ひょっとして
ActiveSheet　と　Worksheets("ボタンなし")　は同じではない？
スクショの取るタイミングも気になります・・が
違うシートなら
Sub スクショ貼付()
keybd_event vbKeySnapshot, 0&, fKEYDOWN, 0&
keybd_event vbKeySnapshot, 0&, fKEYUP, 0&
Application.Wait Now() + TimeValue("00:00:01")
Set ws = Worksheets("ボタンなし")
ws.Select
With ws
.Range("A1").Select
.Paste
'Selection.Copy
Set sp1 = .Shapes(.Shapes.Count)
End With
End Sub
で
念のため
'【サイズ調整】
.LockAspectRatio = msoFalse
.Height = ws.Range("1:30").Height
.Width = ws.Range("a:H").Width
が良いかも

Qchan1962 · Answer

こんな感じでしょうか
ActiveSheet.Range("a:H").Widthでテストしました

'【スクショ貼付】
'キーボードイベント用のライブラリ読み込み
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long _
)

Private Const fKEYDOWN = &H1
Private Const fKEYUP = &H1 Or &H2

Dim ws As Worksheet
Dim sp1 As Shape

Sub コール()

'プリントスクリーンボタンを押し、スクショを取って、エクセルに貼付する
Call スクショ貼付

'撮ったスクショを、自由なサイズにトリミングする,自由なサイズに変更する
Call トリミングサイズ調整

'変更したサイズを印刷する
Call 印刷

End Sub

'4 つのマクロのコードです↓↓↓

Sub スクショ貼付()
Set ws = ActiveSheet
keybd_event vbKeySnapshot, 0&, fKEYDOWN, 0&
keybd_event vbKeySnapshot, 0&, fKEYUP, 0&
Application.Wait Now() + TimeValue("00:00:01")
With ws
.Range("A1").Select
.Paste
'Selection.Copy
Set sp1 = .Shapes(.Shapes.Count)
End With
End Sub

'【トリミングサイズ調整】
Sub トリミングサイズ調整()
Const OffTop As Double = 0 '上の切り取り
Const OffLeft As Double = 0 '左の切り取り
Const OffBottom As Double = 0 '下の切り取り
Const OffRight As Double = 500 '右の切り取り

With sp1
.PictureFormat.CropTop = OffTop
.PictureFormat.CropLeft = OffLeft
.PictureFormat.CropBottom = OffBottom
.PictureFormat.CropRight = OffRight
'【サイズ調整】
.LockAspectRatio = msoFalse
.Height = ActiveSheet.Range("1:30").Height
.Width = ActiveSheet.Range("a:H").Width

End With
End Sub

'【印刷】
Sub 印刷()
ws.PrintOut
End Sub

Qchan1962 · Answer

＞今度は、トリミングは出来たのですがサイズ調・・
トリミング処理に入れてしまえば・・と思いますがSubを分けている意味が御有りなのでしょうから・・分けるとして

同じShapeを対象にするのなら　変数スコープをモージュールレベルに変更して
同じ変数を使用するのはいかがでしょう

Dim sp1 As Shape
Sub コール()
・・
End Sub
Sub トリミング()
・
・
Dim ws As Worksheet
Set ws = ActiveSheet
Set sp1 = ws.Shapes(ws.Shapes.Count)
・
・
End Sub

Sub サイズ調整()
With sp1
.LockAspectRatio = msoFalse
.Height = ActiveSheet.Range("1:30").Height
.Width = ActiveSheet.Range("a:ao").Width
End With
End Sub

試していないのでダメでしたらごめんなさい

Qchan1962 · Answer

こんばんは
＃１様がすでに回答済みですので、通常の対策コードだけですが
Set sp1 = ws.Shapes(1)　を
Set sp1 = ws.Shapes(ws.Shapes.Count)に変更してみてください

最後に追加されたShapeがセットできると思います

fujillin · Answer

こんばんは

情報が不足しているので、断言はできませんが・・

＞⇒エクセル上にマクロボタンを付けた場合
＞⇒動かない
対象の図形を
＞Set sp1 = ws.Shapes(1)
と決め打ちにしているので、ボタンを取得しているのではないかと推測します。
ウォッチ式などで、Shapes(1)の実態が何かを確認すればわかるのではないでしょうか。

エラーメッセージが「そのようなプロパティはない」といった内容ではないかと推測しますが、
「PictureFormatプロパティは画像または OLE オブジェクトに適用されます」
となっていますので、ボタンをそれ以外で作成しているってことではないでしょうか？
https://learn.microsoft.com/ja-jp/office/vba/api/excel.shape.pictureformat

【マクロ】スクショ印刷がうまく動かない件

ひょっとして

こんな感じでしょうか

＞今度は、トリミングは出来たのですがサイズ調・・

こんばんは

こんばんは

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング