Excel 2007 - Menu pro popisky dat na grafu
V jednom projektu jsem potřeboval přidat vlastní tlačítko do místní nabídky (po kliku pravým tlačítkem myši) pro datové popisky na grafu v Excelu 2007.
Nechal sem si tedy vypsat veškeré nabídky které Excel 2007 nabízí a začal jsme hledat tu svou. Ani po několika pokusek a různých testech jsem stále nemohl najít tu mou. Došel jsem k závěru, že Excel 2007 vypisuje některé nabídky "on-line", tedy až když uživatel klikne na objekt, Excel sestaví nabídku a zobrazí ji. Nepodařilo se mi totiž najít vícero takových nabídek pro graf = Excel pro ně nemá žádný vyhrazený název jako je tomu např. pro nabídku "Cells"
CommandBars("Cell").ShowPopup
Aby bylo jasné o kterou nabídku se jedná, přikládám obrázek
Jelikož sem nutně potřeboval přidat tlačítko do této nabídky, rozhodl sem se jít cestou vytvoření si vlastní nabídky, která bude vypadat a bude mít stejnou funkčnost jako vestavěná nabídka Excelu.
Úkol se mi vcelku dobře podařilo splnit až na tři malé vyjímky
- Barva písma v nabídce Excelu je modrá, mnou vytvořená nabídka má černé písmo
- Funkce Edit Text nepracuje úplně stejně, jelikož sem nenašel žádnou metodu klterá by uměla udělat přesně stejnou věc jako vestavěné tlačítko
- Zrušil jsem nabídku "3-D Rotation…"
Níže uvadím kód pro vytvoření vlastní nabídky a veškeré "OnAction" události, které pracují stejně jako vestavěná nabídka Excelu.
Na kódu není nic zvláštního, jedině co stojí za povšimnutí jsou příkazy
GetImageMso v proceduře "CreateOwnPopupMenu"
ExecuteMso v proceduře "ResetToMatchStyle"
!!! P O U Z E P R O E X C E L 2 0 0 7 - 2 0 1 0 !!!
Údálostní procedura na listu s grafem
Private Sub Chart_BeforeRightClick(Cancel As Boolean)
If TypeName(Selection) = "DataLabel" Then
Cancel = True
Call CreateOwnPopupMenu
End If
End Sub
Option Explicit
Const POPUP_NAME As String = "IDC_DataLabel"
'********************************************************************************
' CreateOwnPopupMenu
'
' Purpose: Vytvori vlastni kontektovou nabidku pro popisky grafu a prida vlastni tlacitko.
' Menu vypada jako vestavena nabidka Excelu
' Volano z udalosti 'BeforeRightClick' na ChartSheet
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub CreateOwnPopupMenu()
Dim cbPopup As CommandBar
Dim cbButton As CommandBarControl
'Ensure our popup menu does not exist
Call DeleteCommandBar
'Add our popup menu to the CommandBars collection
Set cbPopup = Application.CommandBars.Add(Name:=POPUP_NAME, Position:=msoBarPopup, MenuBar:=False, Temporary:=False)
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "&Delete"
.OnAction = "DeleteDataLabel"
'.FaceId = 600
.BeginGroup = False
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "Reset to M&atch Style"
.OnAction = "ResetToMatchStyle"
' new way how can get image from Ribbon controls
.Picture = Application.CommandBars.GetImageMso("ChartResetToMatchStyle", 16, 16)
.BeginGroup = False
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "Edit Text"
.OnAction = "EditLabelText"
'.ID 1401
'.FaceId = 4340
.BeginGroup = True
.Visible = True
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "&Font…"
.OnAction = "ShowFontDialog"
.FaceId = 4340
.BeginGroup = False
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "Change Chart T&ype…"
.OnAction = "ChangeChartType"
.FaceId = 17
.BeginGroup = True
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "S&elect Data…"
.OnAction = "SelectChartData"
'.FaceId = 244 ' 6066
' new way how can get image from Ribbon controls
.Picture = Application.CommandBars.GetImageMso("ChartEditDataSource", 16, 16)
.BeginGroup = False
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "Format Data Po∫…"
.OnAction = "FormatDataPoint"
'.FaceId = 600
.BeginGroup = True
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "Format Data &Label…"
.OnAction = "FormatDataLabel"
.FaceId = 222
.BeginGroup = False
End With
Set cbButton = cbPopup.Controls.Add
With cbButton
.Caption = "Change to &Resizeable Textbox"
.OnAction = "ResizeableDataLabel"
.FaceId = 1401
.BeginGroup = True
End With
cbPopup.ShowPopup
Set cbPopup = Nothing
Set cbButton = Nothing
End Sub '********************************************************************************
' DeleteCommandBar
'
' Purpose: Odstrani nabidku
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Private Sub DeleteCommandBar()
On Error Resume Next
CommandBars(POPUP_NAME).Delete
End Sub
'********************************************************************************
'ResizeableDataLabel
'
' Purpose: Excel rozdeluje dlouhe slovo na dva radky (napr. Telekomunikace)
' a protoze excel neposkytuje moznost rozsirit DataLabel, tato rutine
' popisek odstarni a vlozi misto nej obycejne textove pole, ktere je mozne roztahnout.
' Nastavuje pozici Textboxu a jeho vlastnosti
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub ResizeableDataLabel()
Dim objLabelPoint As Point
Dim shTxt As Shape
Dim strErrMsg As String
Dim i As Byte
Dim bolFound As Boolean
Dim sngWidth As Single
Dim sngHeight As Single
On Error GoTo ErrorHandler
If TypeName(Selection) = "Nothing" Then
strErrMsg = "You must select one Data Label point!"
GoTo ErrorHandler
End If
If TypeName(Selection) = "DataLabels" Then
strErrMsg = "You must select only one Data Label point!"
GoTo ErrorHandler
End If
If TypeName(Selection) <> "DataLabel" Then
strErrMsg = "You must select one Data Label point!"
GoTo ErrorHandler
End If
' because I don't know how set up point according to name (Selection.Name)
' (something like - ActiveChart.SeriesCollection(1).Points(Selection.Name).DataLebel)
' I have to compare according to DataLabel name
bolFound = False
For i = 1 To ActiveChart.SeriesCollection.Count
For Each objLabelPoint In ActiveChart.SeriesCollection(i).Points
' compare name
If objLabelPoint.DataLabel.Name = Selection.Name Then
bolFound = True
Exit For
End If
Next objLabelPoint
If bolFound Then
Exit For
End If
Next i
Select Case Len(objLabelPoint.DataLabel.Text)
Case Is < 7
sngWidth = 57
sngHeight = 18
Case Is > 6 < 10
sngWidth = 75
sngHeight = 20
Case Else
sngWidth = 96
sngHeight = 26
End Select
' add new textbox
Set shTxt = ActiveChart.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=objLabelPoint.DataLabel.Left, _
Top:=objLabelPoint.DataLabel.Top, _
Width:=sngWidth, _
Height:=sngHeight)
' set up all prperties
With shTxt
.TextFrame2.TextRange.Text = objLabelPoint.DataLabel.Text
.TextFrame2.TextRange.Font.Name = objLabelPoint.DataLabel.Font.Name
.TextFrame2.TextRange.Font.Size = objLabelPoint.DataLabel.Font.Size
.Name = objLabelPoint.DataLabel.Name
End With
' remove datalabel point
objLabelPoint.DataLabel.Delete
MsgBox "The new resizeable textbox has been inserted into the figure." & vbNewLine & _
String(90, "-") & vbNewLine & _
vbTab & vbTab & vbTab & "N O T I C E!" & vbTab & vbTab & vbTab & vbNewLine & _
String(90, "-") & vbNewLine & _
"The texbox is not bounded with source data!" & vbNewLine & _
"If you do any changes in source data, you will have to re-create the figures.", _
vbInformation, _
"The new resizeable textbox has been inserted"
ExitRoutine:
Set objLabelPoint = Nothing
Set shTxt = Nothing
Exit Sub
ErrorHandler:
If Len(strErrMsg) > 0 Then
MsgBox Prompt:=strErrMsg, _
Title:="Warning", _
Buttons:=vbExclamation
Else
MsgBox Prompt:="Unknown error occured" & vbNewLine & _
"Error description: " & Err.Description & vbNewLine & _
"Error number: " & Err.Number, _
Title:="Unknown error", _
Buttons:=vbExclamation
End If
GoTo ExitRoutine
End Sub
'********************************************************************************
'DeleteDataLabel
'
' Purpose: Smaze oznaceny popisek grafu
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub DeleteDataLabel()
Selection.Delete
End Sub
'********************************************************************************
'DeleteDataLabel
'
' Purpose: Resets selected DataLabel to initial style. Use 'ExecuteMso' command
' because VBA doesn't provide this possibility
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub ResetToMatchStyle()
Application.CommandBars.ExecuteMso "ChartResetToMatchStyle"
End Sub
'********************************************************************************
'EditLabelText
'
' Purpose: Vybere cely text ve vybranem popisku. Pouzivam metodu 'SendKeys'
' protoze sem nenasel zadnou metodu ve VBA, ktera by delal to stejne co
' vestaveny prikza Excelu.
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub EditLabelText()
Application.SendKeys "~"
End Sub '********************************************************************************
'ShowFontDialog
'
' Purpose: Zobrazi dialog pro nastaveni vlastnosti pisma
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub ShowFontDialog()
Application.Dialogs(xlDialogFormatFont).Show
End Sub
'********************************************************************************
'ChangeChartType
'
' Purpose: Zobrazi dialog pro zmenu typu grafu
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub ChangeChartType()
Application.Dialogs(xlDialogChartType).Show
End Sub
'********************************************************************************
'SelectChartData
'
' Purpose: Zobrazi dialog pro editaci zdrojovych dat
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
' TT-440
'
' Modified: .
'
'********************************************************************************
Sub SelectChartData()
Application.Dialogs(xlDialogChartSourceData).Show
End Sub
'********************************************************************************
'FormatDataPoint
'
' Purpose: Excel neposkytuje primo cestu pro zobrazeni dialogu pro Datovy bod (Point)
' Musi byt vybrana datova rada (bod) a poto zavolat dialog pro nastaveni
' datove rady = tzn. reselect datalabel na DataPoint
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub FormatDataPoint()
Dim objLabelPoint As Point
Dim i As Byte
Dim boFound As Boolean
boFound = False
For i = 1 To ActiveChart.SeriesCollection.Count
For Each objLabelPoint In ActiveChart.SeriesCollection(i).Points
' compare name
If objLabelPoint.DataLabel.Name = Selection.Name Then
objLabelPoint.Select
boFound = True
Exit For
End If
Next objLabelPoint
If boFound Then
Exit For
End If
Next i
Application.Dialogs(xlDialogSeriesOptions).Show
Set objLabelPoint = Nothing
End Sub
'********************************************************************************
'FormatDataLabel
'
' Purpose: Zobrazi dialog pro nastaveni vlastnosti popisku
' Volano z kontextove nabidky
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: October 09 Premysl Lazecky
'
' Modified: .
'
'********************************************************************************
Sub FormatDataLabel()
Application.Dialogs(xlDialogChartOptionsDataLabels).Show
End Sub