選択した箇条書きのスライド上の位置を見つける

Question

私は、箇条書きの上にシェイプを配置できるvbaを作成しようとしています（ストックショットがあまりにも退屈なので）。私は各弾丸の位置を決定することができないので、その上に形状を配置することができます。

垂直位置は、整列が難しいほど重要です。弾丸は絶え間なく動いています（形を塗りつぶすために広がっています）が、移動するたびに手動でマクロを再実行するのに問題はありません。

出力を得るには、.Bullet.Leftや.Bullet.Topに似ていますが、どのような形で行うことができますか？

Answer 1

オブジェクトをオーバーレイしてからテキストフレームの自動フォーマットを処理する代わりに、カスタムの箇条書きの形状を.Exportを使用してPNG画像としてファイルシステムにエクスポートし、.Typeを使用して箇条書きとして再インポートすることはできますかこれは次のようになります。

' ================================================================================ 
' PowerPoint VBA Macro 
' Auther : Jamie GArroch of YOUpresent Ltd. http://youpresent.co.uk/ 
' Purpose : exports any on-slide object e.g.shape, group etc. and then 
'   imports it for use as a bullet 
' References : None 
' Requirements : User must select two obects on the slide, one of which must 
'    contain the text to be bulleted 
' Inputs : None 
' Outputs : None 
' ================================================================================ 
Sub ExportShapeAndLoadAsBullet() 
    Dim oShpText As Shape 
    Const TmpPath = "C:\Temp\" ' make sure this path exists or changeto one that does 
    Const BulletName = "myBullet.png" 

    On Error GoTo errorhandler 
    With ActiveWindow.Selection 
    ' Check the user's selection 
    If .Type <> ppSelectionShapes Then 
     MsgBox "Please select the shape to use as a bullet and the text box to apply it to.", vbCritical + vbOKOnly, "Incorrect Selection" 
     Exit Sub 
    End If 
    If .ShapeRange.Count <> 2 Then 
     MsgBox "Please select the shape to use as a bullet and the text box to apply it to.", vbCritical + vbOKOnly, "Incorrect Selection" 
     Exit Sub 
    End If 

    ' Export the object to use as a bullet and set a reference to the object to apply the bullet to 
    If .ShapeRange(1).HasTextFrame Then 
     If .ShapeRange(1).TextFrame.HasText Then 
     Set oShpText = .ShapeRange(1) 
     .ShapeRange(2).Export TmpPath & BulletName, ppShapeFormatPNG 
     End If 
    End If 

    If .ShapeRange(2).HasTextFrame Then 
     If .ShapeRange(2).TextFrame.HasText Then 
     Set oShpText = .ShapeRange(2) 
     .ShapeRange(1).Export TmpPath & BulletName, ppShapeFormatPNG 
     End If 
    End If 
    End With 

    If oShpText Is Nothing Then 
    MsgBox "Couldn't find any text in either shape.", vbCritical + vbOKOnly, "No Text Found" 
    Exit Sub 
    End If 

    ' Apply the exported bullet to the text 
    With oShpText.TextFrame.TextRange.ParagraphFormat.Bullet 
    .Type = ppBulletPicture 
    .Picture TmpPath & BulletName 
    .RelativeSize = 1 
    Kill TmpPath & BulletName 
    End With 

    ' Clean up 
    Set oShpText = Nothing 
Exit Sub 
errorhandler: 
    MsgBox Err & " : ", Err.Description 
End Sub 

これにより、コードポジショニングが不要になり、箇条書き画像の相対的な縮尺を設定することもできます。