PowerPoint UserForm イメージオブジェクトを使い図形の連続セット スタンプ処理もどき

パワポでスタンプ処理 UserForm イメージオブジェクトを使い連続で図形をセットする。
そんな処理を試作
仕組みは単純で、UserFormのイメージコントロールを使い、
イメージが押された位置にスタンプ図形シェイプをセットしてみました

知恵袋の質問
detail.chiebukuro.yahoo.co.jp
にチャレンジしてみました。

下記、いつもの あのあの イライラ 解説動画です。
youtu.be
https://youtu.be/fKNl6FX-h0A
目次
00:00 挨拶、やりたいこと
01:08 スタンプ処理実演
01:49 1.スライド１ページ目にスタンプをセット
02:52 2.UserForm1 に イメージコントロールを貼る
05:32 3.パワポのスライドを画像にして読み込む
07:42 4.クリックイベントで、スタンプをセットする
09:58 蛇足でクリック後に画像を更新する
12:02 コンボボックスでスタンプを選択する
15:11 セット位置のバグを探る・・・

準備
パワポスライド1ページ目に
スタンプ図形を用意
ハートや星など名前を付けてください。(配置 から)
ActivePresentation.Slides(1).Shapes("星").Copy
で使用しています。

UserFormに
Image1コントロールを640x360のサイズで作成
してから、テストしてください。

1.スライド１ページ目にスタンプをセット

星とハートをテストで作成
配置 で スタンプに名前を付ける

2.UserForm1 に イメージコントロールを貼る
マウスのクリック、DownのイベントでX,Yが取れるので、使用してみた

3.フォーム初期化時にパワポのスライドを画像にして読み込む
スライドをJPGへ落とし、利用する

4.イメージコントロールのクリックイベントで、スタンプをセットする
スライド1に用意したスタンプを.Copyして貼り付ける。
位置を再度調べる・・・

ソースコード UserForm1

Option Explicit

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    '図形のコピー 今回はスライド1から固定でテスト
    'ActivePresentation.Slides(1).Shapes("星").Copy
    ActivePresentation.Slides(1).Shapes("ハート").Copy
    
    '現在のスライドPage
    Dim p As Integer
    p = ActiveWindow.Selection.SlideRange.SlideIndex
    
    'pページに貼り付け
    Dim shpR As ShapeRange
    Set shpR = ActivePresentation.Slides(p).Shapes.Paste
    
    Dim shp As Shape
    Set shp = shpR(1)  '↑.PasteでShapeRangeが返るのでその(1)一番目

    '貼り付け位置の調整
    '1280x720を元だとすると、
    '640x360 のイメージエリア と ズーム倍率
    shp.Left = Int(X * (ActiveWindow.Width / 640))
    shp.Top = Int(Y * (ActiveWindow.Height / 360))
    '正しい位置にセットされません、↑失敗してます、アレンジ、修正して使ってください。

End Sub

Private Sub UserForm_Initialize()
    '初期処理でスライド画像を作り、imgコントロールへ読み込む
    
    'File名を作る
    Dim strPATH As String   '保存場所 現在と同じPATHにしたい、ネットワークファイル不可？
    Dim strFNAME As String  '出力ファイル名
    strPATH = ActivePresentation.Path  'パワポ保存場所パス
    strFNAME = strPATH & "\個別スライド.jpg"
    
    '現在のスライドPage
    Dim p As Integer
    p = ActiveWindow.Selection.SlideRange.SlideIndex
    
    'pページスライドのJPGを作る
    ActivePresentation.Slides(p).Export strFNAME, "jpg"
    DoEvents

    '作ったjpg↑をImage1にセット
    Me.Image1.Picture = LoadPicture(strFNAME)
    Me.Image1.AutoSize = False
    Me.Image1.PictureAlignment = fmPictureAlignmentTopLeft '0 左上端
    Me.Image1.PictureSizeMode = fmPictureSizeModeZoom   '3 縦横比
    DoEvents

End Sub

↑ソースコードをアレンジして、使ってみてください。
処理のヒントとなれば幸いです。

---

下記の動画内で、思い付きで修正したコードもよろしくお願いします。

Option Explicit

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    '図形のコピー 今回はスライド1から固定でテスト
    ActivePresentation.Slides(1).Shapes(ComboBox1.Value).Copy
    'ActivePresentation.Slides(1).Shapes("ハート").Copy
    
    '現在のスライドPage
    Dim p As Integer
    p = ActiveWindow.Selection.SlideRange.SlideIndex
    
    'pページに貼り付け
    Dim shpR As ShapeRange
    Set shpR = ActivePresentation.Slides(p).Shapes.Paste
    
    Dim shp As Shape
    Set shp = shpR(1)  '↑.PasteでShapeRangeが返るのでその(1)一番目

    '貼り付け位置の調整
    '1280x720を元だとすると、
    '640x360 のイメージエリア と ズーム倍率
    '失敗、あとで調べる・・・ActiveWindow.Widthではない
    shp.Left = Int(X * (ActiveWindow.Width / 640))
    shp.Top = Int(Y * (ActiveWindow.Height / 360))
    
    'セットした結果を更新
    Call 画像更新

End Sub

Private Sub UserForm_Initialize()
    '初期処理でスライド画像を作り、imgコントロールへ読み込む
    
    ComboBox1.AddItem "星"
    ComboBox1.AddItem "ハート"
    ComboBox1.AddItem "鈴木"
    ComboBox1.AddItem "矢印上"
    
    '初期表示
    Call 画像更新

End Sub

Private Sub 画像更新()

    'File名を作る
    Dim strPATH As String   '保存場所 現在と同じPATHにしたい、ネットワークファイル不可？
    Dim strFNAME As String  '出力ファイル名
    strPATH = ActivePresentation.Path  'パワポ保存場所パス
    strFNAME = strPATH & "\個別スライド.jpg"
    
    '現在のスライドPage
    Dim p As Integer
    p = ActiveWindow.Selection.SlideRange.SlideIndex
    
    'pページスライドのJPGを作る
    ActivePresentation.Slides(p).Export strFNAME, "jpg"
    DoEvents

    '作ったjpg↑をImage1にセット
    Me.Image1.Picture = LoadPicture(strFNAME)
    Me.Image1.AutoSize = False
    Me.Image1.PictureAlignment = fmPictureAlignmentTopLeft '0 左上端
    Me.Image1.PictureSizeMode = fmPictureSizeModeZoom   '3 縦横比
    DoEvents
    
    Me.Repaint  '再描画
    
End Sub