カゲンぱぱのイイカゲンメモ帳: powerpointのイベントを取得

こんななことをやりたい：
・PowerPointのスライドでクリックして、クリックした場所で、入力フォームをたちあげて、入力終わったら、挿入ボタンを押して、入力した内容をshapeとして、挿入点で挿入する。そして、入力内容をコメントに追加する。
クリアしないと行けない難点
１．スライドでクリックするイベントを取得
２．挿入点の座標を取得

むやみにマウスクリックしたら入力フォームが表示されるのもうざいので、モードのON/OFFにします。
さあ、やってみる：
まずPowerPoint（2007）を開く,VBEを立ち上げ（ALT+F11）
クラスを新規追加する、名前は任意、ここでは[cEventClass]とします、下記二行追加。

Option Explicit
Public WithEvents PPTEvent As Application

右上のドロップダウンリストからイベントが選択できるようになるはず、
本当はダブルクリックイベント[PPTEvent_WindowBeforeDoubleClick」を使いたいが、反応ない（BUGだと思います、2007,2010全部だめ見たいが、2003では反応する）シクシク...仕方なく
[PPTEvent_WindowBeforeRightClick]を追加します。

Private Sub PPTEvent_WindowBeforeRightClick(ByVal Sel As Selection, Cancel As Boolean)
'変なとこで右クリックして、エラーなるのを防ぐ為
If Sel.Parent.ActivePane.ViewType <> ppViewSlide Then
    Exit Sub
End If
call showTransForm
'Cancelはメニュー出てこないように
Cancel = True
End Sub

そして、モジュールを追加します。名前は[modEventHandle]とする

Dim cPPTObject As New cEventClass
'座標を取得するため
Public Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Dim TrapFlag As Boolean
'マウスXYを格納するuser type
Public Type POINTAPI
    X As Long
    Y As Long
End Type
'Autp_Openという名前にすれば、pptをアドイン形式に保存すれば、開いた直後に実行されるので、
'アドインとして便利です。開発中はppt(pptm)のままにしとこう（注意：一旦ppa,ppamに保存するとソースコード変更できなくなるので、必ずpptバージョンを残してください。アドイン版はrelease時だけにしましょう）
Sub Auto_Open()
    Dim oToolbar As CommandBar
    Dim oButton As CommandBarButton
    Dim MyToolbar As String

    MyToolbar = "kagen Tools"
    On Error Resume Next
    Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
        Position:=msoBarFloating, Temporary:=True)
    If Err.Number <> 0 Then
          ' ツールバー既に存在
          Exit Sub
    End If
    On Error GoTo ErrorHandler

    Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)

    With oButton
         .DescriptionText = "翻訳モード"
         .Caption = "Translate(&K)"
         .OnAction = "TrapEvents"
         .Style = msoButtonIcon
         .FaceId = 52 '豚
    End With
    oToolbar.Top = 150
    oToolbar.Left = 150
    oToolbar.Visible = True
NormalExit:
    Exit Sub
ErrorHandler:
     MsgBox Err.Number & vbCrLf & Err.Description
     Resume NormalExit:
End Sub

Public Sub TrapEvents()
If TrapFlag = True Then
   Exit Sub
End If
   Set cPPTObject.PPTEvent = Application
   TrapFlag = True
   MsgBox "翻訳モード有効になりました。" & vbNewLine & "右クリックで翻訳を登録する"
End Sub

Public Sub ReleaseTrap()
If TrapFlag = True Then
   Set cPPTObject.PPTEvent = Nothing
   Set cPPTObject = Nothing
   TrapFlag = False
   MsgBox "翻訳モード無効になりました。"
End If
End Sub
Public Function GetXCursorPos() As Long
   Dim pt As POINTAPI
   GetCursorPos pt
   GetXCursorPos = pt.X
End Function
Public Function GetYCursorPos() As Long
   Dim pt As POINTAPI
   GetCursorPos pt
   GetYCursorPos = pt.Y
End Function

Public Sub showTransForm()
    Dim MouseCursorPosX As Long
    Dim MouseCursorPosY As Long
    
    If ((GetXCursorPos() / (ActiveWindow.View.Zoom / 100)) - 355) < 0 Then
        MouseCursorPosX = 0
    ElseIf ((GetXCursorPos() / (ActiveWindow.View.Zoom / 100)) - 355) > 720 Then
        MouseCursorPosX = 720
    Else
        MouseCursorPosX = (GetXCursorPos() / (ActiveWindow.View.Zoom / 100)) - 355
    End If
    
    If ((GetYCursorPos() / (ActiveWindow.View.Zoom / 100)) - 226) < 0 Then
        MouseCursorPosY = 0
    ElseIf ((GetYCursorPos() / (ActiveWindow.View.Zoom / 100)) - 226) > 540 Then
        MouseCursorPosY = 540
    Else
        MouseCursorPosY = (GetYCursorPos() / (ActiveWindow.View.Zoom / 100)) - 226
    End If
    
    transForm.m_insertPointX = MouseCursorPosX
    transForm.m_insertPointY = MouseCursorPosY
    transForm.Top = MouseCursorPosY
    transForm.Left = MouseCursorPosX
    transForm.Show
End Sub

訳語を入れるフォームを作成する

'*** Place this code In a User Form ***
Option Explicit

Private m_clsResizer As CResizer
Public m_insertPointX As Long
Public m_insertPointY As Long



Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdInsert_Click()
Dim sld As Slide
Dim shp As Shape
Dim objText As TextRange
Dim vntTateS As Variant
Dim vntYokoS As Variant
Dim vntTate As Variant
Dim vntYoko As Variant
Dim intY As Integer
Dim intX As Integer
Dim posOffsetX As Long
Dim posOffsetY As Long

posOffsetX = 35
posOffsetY = 35
intY = 0
intX = 0
If TextBox1.Text <> "" Then
    TextBox1.Text = Replace(TextBox1.Text, "｜", "|")
    Set sld = Application.ActiveWindow.View.Slide
    vntTateS = Split(TextBox1.Text, vbNewLine)
    For Each vntTate In vntTateS
        vntYokoS = Split(vntTate, "|")
        For Each vntYoko In vntYokoS
            Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, Left:=m_insertPointX + intX * posOffsetX, Top:=m_insertPointY + posOffsetY * intY, Width:=40, Height:=25)
            shp.Fill.ForeColor.RGB = vbWhite
            shp.Line.Visible = msoFalse
            shp.TextFrame.TextRange.Font.Color = vbBlack
            shp.TextFrame.WordWrap = msoFalse
            shp.TextFrame.TextRange.Font.Size = 11
            shp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
            shp.TextFrame.TextRange.Text = vntYoko
            intX = intX + 1
        Next
        intY = intY + 1
    Next
    Set objText = sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
    objText.Text = objText.Text & IIf(objText.Text <> "", vbNewLine, "") & TextBox1.Text
End If
Unload Me
End Sub
Private Sub UserForm_Initialize()
    'Call RemoveCaption(Me)
    With Me
        .StartUpPosition = 0
        .Top = 175
        .Left = Application.Left + Application.Width - Me.Width * 2
    End With
    Set m_clsResizer = New CResizer
    m_clsResizer.Add Me
End Sub


Private Sub UserForm_Resize()
    TextBox1.Width = transForm.Width - 6
    TextBox1.Height = IIf(transForm.Height - 47 < 63, 63, transForm.Height - 47)
    cmdInsert.Top = TextBox1.Top + TextBox1.Height + 4
    cmdCancel.Top = TextBox1.Top + TextBox1.Height + 4
    cmdInsert.Left = 492
    cmdCancel.Left = 396
End Sub


Private Sub UserForm_Terminate()
    Set m_clsResizer = Nothing
End Sub

フォームをリサイズできるためのクラス

Option Explicit

Private Const MFrameResizer = "FrameResizeGrab"
Private Const MResizer = "ResizeGrab"
Private WithEvents m_objResizer As MSForms.Frame
Private m_sngLeftResizePos As Single
Private m_sngTopResizePos As Single
Private m_blnResizing As Single
Private WithEvents m_frmParent As MSForms.UserForm
Private m_objParent As Object

Private Sub Class_Terminate()

    m_objParent.Controls.Remove MResizer
    
End Sub


Private Sub m_frmParent_Layout()
    
    If Not m_blnResizing Then
        With m_objResizer
            .Top = m_objParent.InsideHeight - .Height
            .Left = m_objParent.InsideWidth - .Width
        End With
    End If

End Sub


Private Sub m_objResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    If Button = 1 Then
        m_sngLeftResizePos = X
        m_sngTopResizePos = Y
        m_blnResizing = True
    End If
    
End Sub
Private Sub m_objResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    If Button = 1 Then
        With m_objResizer
            .Move .Left + X - m_sngLeftResizePos, .Top + Y - m_sngTopResizePos
            m_objParent.Width = m_objParent.Width + X - m_sngLeftResizePos
            m_objParent.Height = m_objParent.Height + Y - m_sngTopResizePos
            .Left = m_objParent.InsideWidth - .Width
            .Top = m_objParent.InsideHeight - .Height
        End With
    End If
    
End Sub
Private Sub m_objResizer_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        m_blnResizing = False
    End If
End Sub

Public Function Add(Parent As Object) As MSForms.Frame
'
' add resizing control to bottom righthand corner of userform
'
    Dim labTemp As MSForms.Label
    
    Set m_frmParent = Parent
    Set m_objParent = Parent
    
    Set m_objResizer = m_objParent.Controls.Add("Forms.Frame.1", MFrameResizer, True)
    Set labTemp = m_objResizer.Add("Forms.label.1", MResizer, True)
    With labTemp
        With .Font
            .Name = "Marlett"
            .Charset = 2
            .Size = 14
            .Bold = True
        End With
        .BackStyle = fmBackStyleTransparent
        .AutoSize = True
        .BorderStyle = fmBorderStyleNone
        .Caption = "o"
        .MousePointer = fmMousePointerSizeNWSE
        .ForeColor = RGB(100, 100, 100)
        .ZOrder
        .Top = 1
        .Left = 1
        .Enabled = False
    End With
    
    With m_objResizer
        .MousePointer = fmMousePointerSizeNWSE
        .BorderStyle = fmBorderStyleNone
        .SpecialEffect = fmSpecialEffectFlat
        .ZOrder
        .Caption = ""
        .Width = labTemp.Width + 1
        .Height = labTemp.Height + 1
        .Top = m_objParent.InsideHeight - .Height
        .Left = m_objParent.InsideWidth - .Width
    End With
End Function

サンプル
ダウンロード後、マクロを信頼して、「TrapEvents」を実行する

カゲンぱぱのイイカゲンメモ帳

2015年3月2日月曜日

powerpointのイベントを取得

0 件のコメント:

コメントを投稿