Jdi na obsah Jdi na menu
 


Excel 2007 - Menu pro popisky dat na grafu

30. 10. 2009

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


Chart_Series_Point_Popup_menu.PNG

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 !!!

Sešit s funkční ukázkou

Ú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

 

Komentáře

Přidat komentář

Přehled komentářů

Zatím nebyl vložen žádný komentář
 

 

 

Z DALŠÍCH WEBŮ

REKLAMA