こんななことをやりたい：
・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」を実行する
