WSHでクリップボードの内容をpptに貼り付け

 WSHでクリップボードの内容をpptに貼り付け

動作未確認です。

'sub pptpaste

    'On Error resume Next

    Dim objWshShell,PPTapp

    Set objWshShell =WScript.CreateObject("WScript.Shell")

    Set PPTapp=CreateObject("powerpoint.Application")

    'Activate PowerPoint Window

    objWshShell.AppActivate GetProcID("powerpoint.exe")

    'PPTapp.WindowState = 1

    PPTapp.visible=true

    Set PPTPre = PPTapp.ActivePresentation

    ' If there is no presentation, Open new presentation

    If Err.Number <> 0 Then

        Set PPTPre = PPTapp.Presentations.Add

        Set PPTsl = PPTPre.Slides.Add(1, 12)

        Err.Clear

    End If

    If PPTapp.ActiveWindow.Selection.Type = 1 Then

        PPTapp.ActiveWindow.WiewType = 1

        PPTapp.ActiveWindow.WiewType = 9

    End If

   

    now_slno = PPTapp.ActiveWindow.Selection.SlideRange.SlideIndex

   

    Set PPTsl = PPTPre.Slides(now_slno)

    PPTsl.Select

   

 '   Dim w, h

 '   w = PPTPre.PageSetup.Slidewidth

 '   h = PPTPre.PageSetup.SlideHeight

   

'    PPTsl.Shapes.PasteSpecial DataType:=2

     PPTsl.Shapes.Paste

   

    For m = 1 To 600 Step 1

        Wscript.sleep 10

        If PPTsl.Shapes.Count >= zu + 1 Then Exit For

        If m = 400 Then PPTapp.CommandBars.ExecuteMso "PastePicture"

        If m = 590 Then

            Set PPTapp = Nothing: Set PPTPre = Nothing: Set PPTsl = Nothing

            'GoTo myerr:

        End If

    Next

   

    zu = PPTsl.Shapes.Count

'    If PPTsl.Shapes(zu).Width > w - 40 Then PPTsl.Shapes(zu).Width = w - 10

'    If PPTsl.Shapes(zu).Height > h - 70 Then PPTsl.Shapes(zu).Height = h - 70

    PPTsl.Shapes(zu).Left = 4

    PPTsl.Shapes(zu).Top = 61

    If pgdown Then PPTPre.Slides(now_slno + 1).Select

   

   ' PPTapp.Activate

   Set PPTapp = Nothing: Set PPTPre = Nothing: Set PPTsl = Nothing

 '  Exit Sub

WScript.Quit

Function GetProcID(ProcessName)

    Dim Service

    Dim QfeSet

    Dim Qfe

    Dim intProcID

    Set Service = WScript.CreateObject("WbemScripting.SWbemLocator").ConnectServer

    Set QfeSet = Service.ExecQuery("Select * From Win32_Process Where Caption='"& ProcessName &"'")

    intProcID = 0

    For Each Qfe in QfeSet

        intProcID = Qfe.ProcessId

        Exit For

    Next

    GetProcID = intProcID

End Function