Jen pro úplnost. Jsou v tom obě verze, barvení při editování i při promítání.
Pro barvení při promítání:
Vybrat graf, záložka Vložit, Akce, Kliknutí myši, Spustit makro: KlikaciGraf
(Trochu jsem blbnul s Win API, nakonec to bylo celkem jednoduché, jen se musí ke každému grafu připojit makro samostatně, případně dalším makrem. Špatně se to ladí.)
Normální modul:
Dim pptClassObjekt As New pptClass
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
Private Declare Function GetCursorPos Lib "user32" (lpPoint As CURSORPOS) As Long
Private Type CURSORPOS
x As Long
y As Long
End Type
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Sub Test()
Set pptClassObjekt.PPTEvent = Application
End Sub
Sub Konec()
Set pptClassObjekt = Nothing
End Sub
Sub KlikaciGraf(oShape As Shape)
ObarvitGraf oShape
RefreshSlide
End Sub
Private Sub ObarvitGraf(oShape As Shape)
Dim poziceMysi As CURSORPOS
Dim ElementID As Long, Arg1 As Long, Arg2 As Long
Dim x As Long, y As Long
Dim aZoom As Single
Call GetCursorPos(poziceMysi)
If Application.SlideShowWindows.Count > 0 Then
aZoom = ActivePresentation.SlideShowWindow.View.Zoom / 100
x = (poziceMysi.x - oShape.Left * aZoom / pointsPerPixelX()) / aZoom
y = (poziceMysi.y - oShape.Top * aZoom / pointsPerPixelY()) / aZoom
Else
x = poziceMysi.x - ActiveWindow.PointsToScreenPixelsX(oShape.Left)
y = poziceMysi.y - ActiveWindow.PointsToScreenPixelsY(oShape.Top)
End If
oShape.Chart.GetChartElement x, y, ElementID, Arg1, Arg2
If ElementID = xlSeries Then
With oShape.Chart.SeriesCollection(Arg1)
With .Points(Arg2)
.Format.Fill.ForeColor.RGB = RGB(255, 0, 50)
End With
End With
End If
End Sub
Private Sub RefreshSlide()
Dim lSlideIndex As Long
lSlideIndex = SlideShowWindows(1).View.CurrentShowPosition
SlideShowWindows(1).View.GotoSlide lSlideIndex
End Sub
Private Function pointsPerPixelX() As Double
Dim hDC As Long
hDC = GetDC(0)
pointsPerPixelX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC 0, hDC
End Function
Private Function pointsPerPixelY() As Double
Dim hDC As Long
hDC = GetDC(0)
pointsPerPixelY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
End Function
class modul pptClass:
Public WithEvents PPTEvent As Application
Private Sub Class_Terminate()
Set PPTEvent = Nothing
End Sub
Private Sub PPTEvent_WindowSelectionChange(ByVal Sel As Selection)
With Sel
If .Type = ppSelectionShapes Then
If .ShapeRange.Type = msoChart Then
ObarvitGraf .ShapeRange(1)
.Unselect
End If
End If
End With
End Sub
citovat