PowerPoint (一般・VBA)

PowerPoint 一般・VBAに関する話題を扱うフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : PowerPoint 2016)
スライドショー実行中の図形(オブジェクト)のVBA操作について
投稿日時: 20/10/23 23:01:15
投稿者: WinArrow
投稿者のウェブサイトに移動

Ofice2019の環境です。
 
スライドショー実行中の画面を印刷したくて
PrintScreen(API)を使ったコードを作りました。
 
実行中の任意のタイミングで印刷するために動作設定ボタン(Caption:画面印刷)を配置しました。
動作設定ボタンには、マクロを実行するようにしてあります。
 
問題は、
画面印刷すると、同さ設定ボタンも印刷されてしまいので、
PrintScreenを実行する前に、動作設定ボタンを非表示にしているのですが、
なぜか、動作設定ボタンが表示状態で印刷されます。
 
DoEventsをかませたり、Sleep(3〜10秒)で時間調整、ボタンの移動、透明化など試みたが、効き目なしです。
そもそも、低速なVBAとの相性がよくないのでしょうか?
 
 
以下が作成したコードです。添削をお願いします。
 

#If VBA7 And Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
    ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
Private Declare Sub keybd_event Lib "user32"(ByVal bVk As Byte, _
    ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If

Private Const KEYEVENTF_EXTENDEDKEY As Long = &H1
Private Const KEYEVENTF_KEYUP As Long = &H2
Private Const VK_LMENU As Long = &HA4
Private Const fKEYDOWN = KEYEVENTF_EXTENDEDKEY
Private Const fKEYUP = KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP

Private xlApp As Object
Const xlLandscape = 2

Sub PrtSc()
Dim shape As shape, S As Long
    S = SlideShowWindows(1).View.CurrentShowPosition
    For Each shape In Application.ActivePresentation.Slides(S).Shapes
        If shape.Type = 1 And shape.HasTextFrame Then
            If shape.TextEffect.Text = "画面印刷" Then
                shape.Visible = msoFalse
                Exit For
            End If
        End If
    Next
    DoEvents
    Sleep 3000
    keybd_event VK_LMENU, 0&, fKEYDOWN, 0&
    keybd_event vbKeySnapshot, 0&, fKEYDOWN, 0&
    keybd_event vbKeySnapshot, 0&, fKEYUP, 0&
    keybd_event VK_LMENU, 0&, fKEYUP, 0&

    DoEvents
    Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .ScreenUpdating = False
        .Visible = True
        With .workbooks.Add
            With .sheets(1)
                .Paste
                xlApp.cutcopymode = False
                .Shapes(1).ScaleWidth 0.64, False
                .PageSetup.Orientation = xlLandscape
                .PrintOut
            End With
            .Close False
        End With
        .Quit
    End With
    Set xlApp = Nothing
    shape.Visible = msoTrue
End Sub

 
 
 
 

投稿日時: 20/10/24 09:29:21
投稿者: WinArrow
投稿者のウェブサイトに移動

プリントスクリーンを2回実行すると、
ボタンが非表示で印刷されました。
Sleep 3000 は、時間かけすぎなんで、1000にしても大丈夫かな?
少し、光が見えてきた、感じがします。
 
他に、対応方法がありましたら、お願いします。
 
もう少し、開けておきます。
 

回答
投稿日時: 20/10/24 16:57:22
投稿者: んなっと

Application.Callerの代わりに、クリックされた自分自身のオブジェクトを引数に渡せます。
あと、アニメーションの位置を含めた画面再描画は、
.GotoSlide .CurrentShowPosition, msoFalse
です。
下のコードでは省きましたが、Sleepがあった方が絶対に確実です。
 
Sub PrtSc(S As Shape)
  S.Visible = msoFalse
  With SlideShowWindows(1).View
    .GotoSlide .CurrentShowPosition, msoFalse
  End With
  DoEvents
  keybd_event VK_LMENU, 0&, fKEYDOWN, 0&
  keybd_event vbKeySnapshot, 0&, fKEYDOWN, 0&
  keybd_event vbKeySnapshot, 0&, fKEYUP, 0&
  keybd_event VK_LMENU, 0&, fKEYUP, 0&
  DoEvents
  Set xlApp = CreateObject("Excel.Application")
  With xlApp
    .ScreenUpdating = False
    .Visible = True
    With .Workbooks.Add
      With .Sheets(1)
        .Paste
        xlApp.cutcopymode = False
        .Shapes(1).ScaleWidth 0.64, False
        .PageSetup.Orientation = xlLandscape
        .PrintOut
      End With
      .Close False
    End With
    .Quit
  End With
  Set xlApp = Nothing
  S.Visible = msoTrue
End Sub

投稿日時: 20/10/25 11:22:52
投稿者: WinArrow
投稿者のウェブサイトに移動

んなっと さん
 
レスありがとうございました。
頂いたコードで、意図した動きが確認できました。
 
頂いたコードの中の「再描画」を拝見して、
実は、Sleepで時間調整をする前に、
ExcelのRepaintのようなものを探していたことを思い出しました。
なかなか見つけることができなかったので、半分あきらめていました。
 
今回、幾つか勉強させていただきました。
@マクロを設定したオブジェクトが引数として認識できること。
 ExcelのApplication.Callerと同じ機能と理解しました。
A再描画ができたこと。
 
大変、ありがとうございました。
解決とさせていただきます。