AW: msoControlPopup per VBA aufklappen
15.03.2017 07:23:04
Mullit
Hallo Martin,
ok, dann mal ran, vorab zur Theorie, wie Du schon richtig erkannt hast, läuft nach Aufruf der ShowPopup-Methode ähnlich wie nach Verwenden der Msgbox-Funktion kein Code mehr, d.h. man muß Code, der die Execute-Anw. ausführt, vor dem Einblenden des Popups anlaufen lassen, mit der Möglichkeit, daß er erst hinterher ausgeführt wird >>> das geht mit dem Api-Timer.
Hier also ein Bsp. der gesamte Code kommt in ein Standardmodul, dann 'prcCreatePopup' laufen lassen, einbauen in Dein Urkundenteil mußt Du's dann noch selbst...
' **********************************************************************
' Modul: Modul1 Typ: Standardmodul
' **********************************************************************
Option Explicit
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
lpPoint As POINTAPI) As Long
Private Const GC_POPUP_BAR As String = "My_Menu_Bar"
Private Const GC_POPUP_POSITION As Long = 4
Private Type POINTAPI
x As Long
y As Long
End Type
Public Sub prcCreatePopup()
Dim udtCursorPos As POINTAPI
Call prcDeletePopup
With Application.CommandBars.Add(Name:=GC_POPUP_BAR, _
Position:=msoBarPopup, Temporary:=True)
Call prcAddButtons(prcmbControls:=.Controls, pvlngMax:=6)
Call GetCursorPos(udtCursorPos)
Call prcStartTimer
Call .ShowPopup(x:=udtCursorPos.x + 50, _
y:=udtCursorPos.y + 50)
End With
Call prcDeletePopup
End Sub
Private Sub prcDeletePopup()
Dim cmbBar As CommandBar
For Each cmbBar In Application.CommandBars
With cmbBar
If .Name = GC_POPUP_BAR And _
.Type = msoBarTypePopup Then _
Call .Delete
End With
Next
End Sub
Private Sub prcAddButtons(ByRef prcmbControls As CommandBarControls, _
ByVal pvlngMax As Long)
Dim strText As String
Dim lngIndex As Long
If pvlngMax = 3 Then strText = "_Pop " _
Else: strText = " "
With prcmbControls
For lngIndex = 1 To pvlngMax
With .Add(Type:=msoControlButton, Temporary:=True)
.Caption = "Button" & strText & lngIndex
.OnAction = "TestMakro"
If pvlngMax = 3 And lngIndex = 3 Then _
.State = msoButtonDown
End With
Next
If pvlngMax = 6 Then
With .Add(Type:=msoControlPopup, _
Before:=GC_POPUP_POSITION, Temporary:=True)
Call prcAddButtons(prcmbControls:=.Controls, pvlngMax:=3)
.Caption = "My_Popup"
End With
End If
End With
End Sub
Private Sub TestMakro()
MsgBox Application.CommandBars.ActionControl.Caption
End Sub
Private Sub prcStartTimer()
Call SetTimer(Application.hwnd, 0&, 10&, AddressOf TimerProc)
End Sub
Private Sub prcStopTimer()
Call KillTimer(Application.hwnd, 0&)
End Sub
Private Sub TimerProc(ByVal pvlngHwnd As Long, ByVal pvlngnIDEvent As Long, _
ByVal pvlnguElapse As Long, ByVal pvlnglpTimerFunc As Long)
Static slngTimerFunc As Long
If slngTimerFunc = 0 Then slngTimerFunc = pvlnglpTimerFunc
With Application.CommandBars(GC_POPUP_BAR)
If .Visible Then
Call prcStopTimer
slngTimerFunc = 0
Call .Controls(GC_POPUP_POSITION).Execute
ElseIf pvlnglpTimerFunc - slngTimerFunc > 50 Then
Call prcStopTimer
slngTimerFunc = 0
Call MsgBox("Can't show Popup...!", vbExclamation, "Error")
End If
End With
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
Gruß, Mullit
