PowerPoint Problem
Berndi
Ich habe eine Frage bezüglich eines VBA-Scripts, das ich in PowerPoint ablaufen lassen möchte.
Da ich mit Euch immer gute Erfahrungen gemacht habe, frage ich einfach mal hier, in der Hoffnung, dass mir wieder geholfen wird, obwohl es sich explizit nicht um ein Excel-VBA-Script handelt.
Bitte verzeiht mir!
Das Script habe ich im Internet gefunden und würde es gerne an meine Bedüfnisse anpassen, aber leider klappt das so nicht und ich weiß nicht warum.
Das Script fragt die Mausposition ab und erstellt an dieser Stelle ein Textfeld.
Ich möchte an dieser Stelle aber ein s.g. Callout-Flag setzen.
Die Fuktions-ID dafür habe ich bereits herausgefunden und im Script eigefügt.
Leider tut sich nichts.
Kann sich bitte, bitte, bitte jemand mal dieses Problems annehmen ?
Tausend Dank !
Berndi
'Option Explicit
'============================================================================
' Alternative um die AddressOf() -Fkt. unter Office 97 zu ersetzen
'============================================================================
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias "EbGetExecutingProj" ( _
ByRef hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long
Private Declare Function GetAddr Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" ( _
ByVal hProject As Long, _
ByVal strFunctionId As String, _
ByRef lpfn As Long) As Long
'============================================================================
' Windowstimer setzen
'============================================================================
Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) _
As Long
'============================================================================
' Windowstimer löschen
'============================================================================
Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Public Const lngAPITIMER As Long = &H10000
Public lngTIMERID As Long
Public Function AddrOf(strFuncName As String) As Long
' gibt den Funktionszeiger einer public VBA Funktion zurück
' Parameter: strFuncName ... Funktionsname
' Return: >0 Adresse, 0 Fehler
' Aufruf zb lFuncPtr& = AddrOf("MyPublicFunc")
Dim hProject As Long, lResult As Long, lpfn As Long
Dim strID As String, strFuncNameUnicode As String
Const NO_ERROR = 0
AddrOf = 0
' Konvert strFuncName Unicode
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
' Handle des VBA - Moduls holen
Call GetCurrentVbaProject(hProject)
If hProject 0 Then
' FunktionsID der VBA-Funktion ermitteln
lResult = GetFuncID(hProject, strFuncNameUnicode, strID)
If lResult = NO_ERROR Then
' Adresse des FunktionsID holen
lResult = GetAddr(hProject, strID, lpfn)
If lResult = NO_ERROR Then: AddrOf = lpfn
End If
End If
End Function
Sub NeuesTextfeld()
On Error Resume Next
'------------------------------------------------------------------------
' Ruft den Befehl Einfügen Textfeld (Id:=139) auf
'------------------------------------------------------------------------
CommandBars.FindControl(Id:=139).Execute
'------------------------------------------------------------------------
' Ruft den Befehl Einfügen Line Callout 3 (Id:=1177 oder 1226) auf
'------------------------------------------------------------------------
'CommandBars.FindControl(Id:=1226).Execute
'------------------------------------------------------------------------
' Startet den Windowstimer und ruft alle 100 Millisekunden die Prozedur
' "Timer_Procedure" auf
'------------------------------------------------------------------------
lngTIMERID = SetTimer(0, lngAPITIMER, 100, AddrOf("Timer_Procedure"))
End Sub
Public Sub Timer_Procedure()
On Error Resume Next
'------------------------------------------------------------------------
' Wenn die Markierung im Textfeld steht, ist das Textfeld eingefügt worden.
' Nun wird der Timer gelöscht, und es kann weitergehen mit dem Ausblenden des Randes
' Dieser bescheidene Teil stammt von Lisa
'------------------------------------------------------------------------
' If Selection.StoryType = wdTextFrameStory Then
KillTimer 0, lngTIMERID
With Selection
' .ShapeRange.Line.Visible = msoFalse
' .ShapeRange.TextFrame.MarginLeft = 0#
' .ShapeRange.TextFrame.MarginRight = 0#
' .ShapeRange.TextFrame.MarginTop = 0#
' .ShapeRange.TextFrame.MarginBottom = 0#
' .Collapse
End With
End If
End Sub