Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | Диаграмма & Графика


Rambler's Top100


Counter CO.KZ


    [1] [2]

  1. Как создать лист диаграммы ? 02.05.2007
  2. Как удалить сразу все листы диаграмм ? 02.05.2007
  3. Как удалить сразу все диаграммы, расположенные в рабочем листе ? NEW 12.10.2016
  4. Как создать рабочую книгу с одним единственным листом диаграммы ? 09.03.2011
  5. Как создать событие для диаграммы, расположенной в рабочем листе ? 17.07.2007
  6. Как распечатать все диаграммы в нужном рабочем листе ? 12.12.2006
  7. Как программно вращать об'ёмную круговую диаграмму ? 16.12.2006
  8. Как программно создать заголовок для диаграммы с несколькими рядами ? 16.12.2006
  9. Как программно обновить уже построенную диаграмму, а при необходимости и скрыть ? 30.04.2007
  10. Как программно узнать имя диаграммы, расположенной в рабочем листе ? NEW 04.09.2016
  11. Как программно переместить диаграмму из одного рабочего листа в другой ? NEW 30.08.2016
  12. Как сохранить диаграмму в виде .pdf файла ? NEW 04.09.2016
  13. Как экспортировать диаграмму в графический файл ? 24.09.2006
  14. Как используя стандартное контекстное меню сохранить выбранную диаграмму в графический файл ? 04.02.2007
  15. Как сохранить все диаграммы, расположенные на листах диаграмм, в нужную папку в виде графических файлов ? 09.01.2007
  16. Как сохранить все диаграммы в папку, где расположена книга, в виде графических файлов ? 09.01.2007
  17. Как сохранить любой рисунок в виде графического файла ? NEW 17.06.2016
  18. Как программно импортировать нужный рисунок ? 07.10.2007
  19. Как импортировать нужный рисунок из интернета ? NEW 20.05.2016
  20. Как импортировать все(или только определённого типа) картинки из выбранной папки ? 01.11.2014
  21. Как определить выделена(активна) диаграмма или нет ? NEW 30.09.2016
  22. Как определить ячейки, к которым привязан графический об'ект ? 08.04.2011
  23. Как определить "пересекаются" или нет графические об'екты с конкретным диапазоном ? NEW 09.05.2016
  24. Как создать копию графического об'екта и разместить его в нужном месте рабочего листа ? 24.05.2008
  25. Как скопировать формат одного графического об'екта и применить его к другим об'ектам (тиражирование формата) ? 24.06.2008
  26. Как удалить все графические об'екты в рабочем листе [без цикла] ? 24.09.2006
  27. Как перебрать все графические об'екты расположенные в нужном рабочем листе ? 26.02.2007
  28. Как перебрать в цикле только OLEObject ? 26.02.2007
  29. Как узнать имя Shape вызвавшего макрос ? 26.01.2007
  30. Как определить принадлежность Shape к группе ? 26.01.2007
  31. Как менять цвет заливки автофигуры в зависимости от данных ячейки ? 17.12.2006
  32. Как менять цвет заливки автофигуры в зависимости от дня недели ? 21.06.2007
  33. Как создать всплывающую подсказку для графических об'ектов ? 05.05.2007
  34. Как создать всплывающие подсказки для нужных ячеек ? 03.07.2007
    [1] [2]


  • Ответ :

    Вариант I.
  • ThisWorkbook.Charts.Add
    Вариант II.
    ThisWorkbook.Sheets.Add Type:=xlChart
    Комментарий : Нельзя добавить лист диаграммы, если структура рабочей книги защищена [FAQ]
  • Ответ :
  • Application.DisplayAlerts = False
    ThisWorkbook.Charts.Delete
    Application.DisplayAlerts = True
    With Application
         .DisplayAlerts = False
         .ThisWorkbook.Charts.Delete
         .DisplayAlerts = True
    End With
    Комментарий :
  • - Если у всех листов диаграмм, которые Вы планируете удалить, значение свойства Visible = xlVeryHidden/xlSheetVeryHidden, то попытка их удаления приведёт к ошибке. В противном случае, будут удалены только видимые листы, а также листы, у которых свойство Visible имеет значение xlSheetHidden
  • - После удаления листов, в рабочей книге должен остаться, как минимум, один видимый лист (вне зависимости от типа)
  • - Нельзя удалить листы, если рабочая книга является общей
  • - Нельзя удалить листы, если структура рабочей книги защищена [FAQ]
  • Ответ :

    Для того, чтобы удалить сразу все диаграммы, расположенные на рабочем листе, можно использовать метод Delete об'екта ChartObjects
  • Worksheets(1).ChartObjects.Delete
    Особенности Microsoft Excel 95-2003 Когда рабочий лист защищён в отношении об'ектов, то удаления диаграмм не происходит и никакой ошибки не возникает. Причём не важно, защищены или нет диаграммы.

    Особенности Microsoft Excel 2007

  • В этой версии возникает ошибка 1004, если диаграммы на листе изволят отсутствовать. Чтобы избежать этой ошибки, достаточно предварительно проверить их наличие, т.е.
  • With Worksheets(1).ChartObjects
         If .Count > 0 Then .Delete
    End With
    или
    If Worksheets(1).ChartObjects.Count > 0 Then Worksheets(1).ChartObjects.Delete
  • Кроме того, ошибка возникнет, если рабочий лист защищён в отношении об'ектов, т.е. в отличии от старых версий, здесь, чтобы удалить сразу все диаграммы, без использовании On Error Resume Next
  • With Worksheets(1).ChartObjects
         If Not .Parent.ProtectDrawingObjects _
         Then If .Count > 0 Then .Delete
    End With

  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Для того, чтобы после активации нужного рабочего листа, Вы могли использовать события диаграммы, которая будет расположена в активном рабочем листе, достаточно разместить в модуле этого листа следующий код :
  • Private WithEvents ChartObject As Excel.Chart

    Private Sub Worksheet_Activate()
        Set ChartObject = Me.ChartObjects(1).Chart
        'Укажите существующей индекс(номер) или имя нужной диаграммы
    End Sub
    Теперь, Вы можете создать нужное событие диаграммы : для этого в окне программы [F7] в первом поле со списком нужно выбрать ChartObject, а во втором поле выбрать нужное событие.

    Комментарий : Вместо события рабочего листа Worksheet_Activate() можно использовать событие рабочей книги Worksheet_Open() (вкупе с соответствующими изменениями)
  • Ответ :
  • Private Sub ChartObjects_PrintOut()
        For iCount& = 1 To Worksheets(1).ChartObjects.Count
            Worksheets(1).ChartObjects(iCount&).Chart.PrintOut
        Next
    End Sub
    Private Sub ChartObjects_PrintOut2()
        With Worksheets(1).ChartObjects
             For iCount& = 1 To .Count
                 .Item(iCount&).Chart.PrintOut
             Next
        End With
    End Sub
    Private Sub ChartObjects_PrintOut3()
        Dim iCharts As ChartObjects
        Set iCharts = Worksheets(1).ChartObjects
        For iCount& = 1 To iCharts.Count
            iCharts(iCount&).Chart.PrintOut
        Next
    End Sub

  • Ответ : Скачать пример

    Для поворота диаграммы используется свойство Rotation об'екта Chart.
  • Private Sub ChartRotation()
        If Me.ChartObjects.Count = 0 Then
           MsgBox "В рабочем листе " & Me.Name & " нет диаграммы", vbCritical, ""
           Exit Sub
        End If
        If Me.ChartObjects(1).Locked = True And _
           Me.ProtectDrawingObjects = True Then
           MsgBox "Изменение защищённой диаграммы невозможно", vbCritical, ""
           Exit Sub
        End If
        If Me.ChartObjects(1).Chart.ChartType = xl3DPie Then
           Me.ChartObjects(1).Chart.Rotation = Me.ScrollBars(1).Value
        End If
    End Sub
    В этом примере используется элемент управления Полоса прокрутки с панели инструментов Формы. Минимальное значение которого = 0, максимальное значение = 360. Данный код необходимо разместить в модуле рабочего листа, где находится об'ёмная круговая диаграмма.

    Примечание : В MS Excel 95 этот код нужно разместить в стандартном модуле, заменив ключевое слово Me ссылкой на нужный рабочий лист. В следующих версиях также возможно использование стандартных модулей, но в отличии от версии 7.0 это не является обязательным условием.
  • Ответ : Скачать пример

    Для того, чтобы отобразить заголовок, а затем изменить его текст, используются свойства HasTitle и ChartTitle об'екта Chart. А для создания названия диаграммы используются имена рядов, т.е. свойство Name для каждого об'екта в семействе SeriesCollection.
  • Private Sub ChartObject_Title()
        If Me.ChartObjects.Count = 0 Then
           MsgBox "В рабочем листе " & Me.Name & " нет диаграммы", vbCritical, ""
           Exit Sub
        End If
        If Me.ChartObjects(1).Locked = True And _
           Me.ProtectDrawingObjects = True Then
           MsgBox "Изменение заголовка диаграммы невозможно", vbCritical, ""
           Exit Sub
        End If
        With Me.ChartObjects(1).Chart
             If .SeriesCollection.Count = 0 Then
                MsgBox "Диаграмма не содержит ни одного ряда", vbCritical, ""
                Exit Sub
             End If
             If Me.CheckBoxes(1).Value = xlOn Then
                For iCount& = 1 To .SeriesCollection.Count
                    iTitle$ = iTitle$ & ";" & .SeriesCollection(iCount&).Name
                Next
                .HasTitle = True
                .ChartTitle.Caption = Mid(iTitle$, 2)
                .ChartTitle.Font.Size = 8 'Необязательно
             Else
                .HasTitle = False
             End If
        End With
    End Sub
    В этом примере используется элемент управления Флажок с панели инструментов Формы, который отвечает за отображение или скрытие заголовка диаграммы. Данный код необходимо разместить в модуле рабочего листа, где находится нужная диаграмма.

    Примечание : [См. выше]
  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Для того, чтобы по мере необходимости, например, перед печатью листа, обновить уже имеющеюся диаграмму (в данном примере) используется метод SetSourceData об'екта Chart. Впрочем, можно также воспользоваться методом ChartWizard. За видимость же об'екта, отвечает свойство Visible.
  • Private Sub Update_Chart()
        If Me.ChartObjects.Count = 0 Then
           MsgBox "В рабочем листе " & Me.Name & " нет диаграммы", vbCritical, ""
           Exit Sub
        End If
        If Me.ProtectContents = True Or _
           Me.ProtectDrawingObjects = True Then
           MsgBox "Изменение в защищённом листе нежелательно", vbCritical, ""
           Exit Sub
        End If
        Me.ChartObjects(1).Chart.SetSourceData Source:= _
        Me.Range("A1").CurrentRegion, PlotBy:=xlColumns
    End Sub

    Private Sub Visible_Chart()
        If Me.ChartObjects.Count = 0 Then
           MsgBox "В рабочем листе " & Me.Name & " нет диаграммы", vbCritical, ""
           Exit Sub
        End If
        Me.ChartObjects(1).Visible = Not Me.ChartObjects(1).Visible
    End Sub
    В этом примере используется два графических об'екта, один из которых отвечает за отображение обновление диаграммы, а другой, за скрытие/отображение этой диаграммы. Кроме того, предполагается, что диаграмма построена на основании диапазона, начинающегося с ячейки "A1" Данный код необходимо разместить в модуле рабочего листа, где находится нужная диаграмма.

    Комментарий : Если используются события, типа Worksheet_SelectionChange() и т.п., то перед использованием свойства CurrentRegion желательно блокировать выполнение этих событий [FAQ157]
  • Ответ :

    Для того, чтобы с помощью VBA узнать имя существующей диаграммы, расположенной в рабочем листе, можно использовать :

    - свойство Name об'екта ChartObject. В этом случае мы получим только имя диаграммы.
  • MsgBox Worksheets(1).ChartObjects(1).Name
    MsgBox Worksheets("Лист1").ChartObjects(1).Name
    - свойство Name об'екта Chart. В этом случае мы получим имя, включающее в себя ещё и имя рабочего листа, где находится диаграмма. Например, "Лист1 Диагр. 1" или "Лист1 Chart 1"
    MsgBox Worksheets(1).ChartObjects(1).Chart.Name
    MsgBox Worksheets("Лист1").ChartObjects(1).Chart.Name

  • Ответ :

    Для того, чтобы переместить существующую диаграмму, из одного рабочего листа в другой, можно использовать любой из нижеопубликованных вариантов.

    Вариант I. Используем метод Location об'екта Chart. Обратите внимание на то, что лист-приёмник, это не об'ект, а просто имя листа, т.е. строка.
  • Worksheets("Лист1").ChartObjects(1).Chart.Location xlLocationAsObject, "Лист3"
    Если мы не знаем имя рабочего листа, куда необходимо переместить диаграмму, то :
    Worksheets(1).ChartObjects(1).Chart.Location xlLocationAsObject, Worksheets(3).Name
    Если после перемещения, нужно изменить месторасположение диаграммы, а также изменить её размер, то в этом случае, можно воспользоваться соответствующими свойствами, т.е. :
    With Worksheets("Лист1").ChartObjects(1).Chart.Location(xlLocationAsObject, "Лист3").Parent
         .Left = 0
         .Top = 0
         '.Width = .Width / 2
         '.Height = .Height / 2
    End With
    Dim iChart As Chart
    Set iChart = Worksheets("Лист1").ChartObjects(1).Chart
    Set iChart = iChart.Location(xlLocationAsObject, "Лист3")

    With iChart.Parent
         .Left = 0
         .Top = 0
         '.Width = 25
         '.Height = 50
    End With
    Dim iChart As ChartObject
    Set iChart = Worksheets("Лист1").ChartObjects(1)
    Set iChart = iChart.Chart.Location(xlLocationAsObject, "Лист3").Parent

    iChart.Left = 0
    iChart.Top = 0
    'iChart.Width = 25
    'iChart.Height = 50
    Вариант II. Используем возможности VBA, аналогичные командам Вырезать и Вставить
    Worksheets(1).ChartObjects(1).Cut
    Worksheets(3).Paste
    Если после перемещения, нужно изменить месторасположение диаграммы, то можно указать ячейку, к которой нам надо "привязать" перемещаемую диаграмму :
    Worksheets(1).ChartObjects(1).Cut
    Worksheets(3).Paste Worksheets(3).Range("A1")
    Если же ячейка не должна служить "якорем", и/или нам необходимо изменить ещё и размеры диаграммы, то :
    Worksheets(1).ChartObjects(1).Cut
    With Worksheets(3)
         .Paste
         With .ChartObjects(.ChartObjects.Count)
              .Left = 0
              .Top = 0
              '.Width = .Width / 2
              '.Height = .Height / 2
         End With
    End With

  • Ответ : Актуально для MS Excel 2007

    Для того, чтобы сохранить существующую диаграмму в виде .PDF файла, можно применить метод ExportAsFixedFormat.

    Если диаграмма расположена в рабочем листе, то :
  • ThisWorkbook.Worksheets(1).ChartObjects(1).Chart.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Диграмма1.pdf"
    Если диаграмма представляет собой отдельный лист, то :
    ThisWorkbook.Charts(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Диграмма2.pdf"
    Примечание : Имейте ввиду, что впервые метод ExportAsFixedFormat появился только в Excel 2007, причём в этой версии, в отличии от последующих, чтобы им воспользоваться, необходимо предварительно установить надстройку от Microsoft. Найти и скачать этот файл SaveAsPDFandXPS.exe , который, собственно, и предназначен для установки дополнения, можно по адресу :

    2007 Microsoft Office Add-in: Microsoft Save as PDF or XPS


  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Если диаграмма расположена в рабочем листе, то :
  • iThisPath = ThisWorkbook.Path
    iFileName = "ChartPicture.gif"

    ThisWorkbook.Worksheets(1).ChartObjects(1).Chart.Export _
    FileName:=iThisPath & "\" & iFileName, FilterName:="GIF"
    Если диаграмма представляет собой отдельный лист, то :
    iThisPath = ThisWorkbook.Path
    iFileName = "ChartPicture.gif"

    ThisWorkbook.Charts(1).Export _
    FileName:=iThisPath & "\" & iFileName, FilterName:="GIF"

  • Ответ : Актуально для MS Excel 97, 2000, XP

    Для того, чтобы после выделения области диаграммы или области построения и клика правой кнопкой мышки, в контекстном меню появилась команда, позволяющая сохранить диаграмму в виде графического файла скопируйте оба макроса и расположите их в любом стандартном модуле личной книги макросов "Personal.xls"
  • Private Sub Auto_Open()
        For Each iBarName In Array("Object/Plot", "Plot Area")
            With Application.CommandBars(iBarName)
                 .Enabled = True
                 .Protection = msoBarNoProtection
                 With .Controls.Add(Type:=msoControlButton, Temporary:=True)
                      .BeginGroup = True
                      .FaceId = 956
                      .Caption = "Экспорт диаграммы"
                      .OnAction = "ChartExport"
                 End With
            End With
        Next
    End Sub

    Private Sub ChartExport()
        iFileName = Application.GetSaveAsFilename( _
        InitialFileName:="Chart", _
        FileFilter:="Формат GIF (*.gif),*gif,Формат JPG (*.jpg),*jpg", _
        Title:="Выберите нужную папку и введите необходимое имя файла")
        If iFileName <> False Then
           ActiveChart.Export FileName:=iFileName, FilterName:=Right(iFileName, 3)
        Else
           MsgBox "Необходимо было указать местосохранение диаграммы", vbCritical, ""
        End If
    End Sub
    Примечание :
  • - Использование свойств Enabled и Protection не носит обязательного характера, но имеет смысл, если контекстное меню могло быть предварительно заблокировано .Enabled = False и/или если меню могло быть защищено от изменений .Protection = msoBarNoCustomize
  • Ответ : Актуально для MS Excel 97, 2000, XP
  • Private Sub ExportAllChart()
        iPath$ = "C:\Диаграммы" 'Or "C:\Диаграммы\"
        'Здесь укажите свою папку для сохранения диаграмм

        If Dir(iPath$, vbDirectory) = "" Then
           MsgBox "Указанная папка " & iPath$ & vbNewLine & _
           "была удалена, перемещена или переименована ", vbExclamation, ""
           Exit Sub
        End If

        If Right(iPath$, 1) <> "\" Then iPath$ = iPath$ & "\"
        'Если при указании папки обязательно использовать PathSeparator
        'в конце пути, то эту строку можно убрать

        Dim iChart As Chart
        For Each iChart In ThisWorkbook.Charts
           iChart.Export _
           FileName:=iPath$ & iChart.Name & ".gif", FilterName:="GIF"
        Next
    End Sub

  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP
  • Private Sub ExportAllCharts()
        iPath$ = ThisWorkbook.Path & "\"

        Dim iSheet As Object
        For Each iSheet In ThisWorkbook.Sheets
            Select Case TypeName(iSheet)
                Case "Chart"
                      iFileName$ = iPath$ & iSheet.Name & ".gif"
                      iSheet.Export FileName:=iFileName$, FilterName:="GIF"
                Case "Worksheet"
                      For iCount& = 1 To iSheet.ChartObjects.Count
                          iFileName$ = iPath$ & iSheet.Name & iCount& & ".gif"
                          iSheet.ChartObjects(iCount&).Chart.Export _
                          FileName:=iFileName$, FilterName:="GIF"
                      Next
            End Select
        Next
    End Sub

  • Ответ : Актуально для MS Excel 2000, XP, 2003

    Если Вы хотите сохранить любой рисунок в виде графического файла, то можно просто определить диапазон, с которым "связан" этот рисунок, и сохранить этот диапазон в виде .html файла. В таком случае, у нас появится доп.папка, содержащая нужный графический рисунок. Если графических файлов будет несколько, то можно будет выбрать файл с наибольшим размером. Причём, осуществить сие действие, можно также с помощью VBA.
  • Private Sub SavePictureInHTML() 'Microsoft Excel 2000, XP, 2003
        Dim iList As Worksheet, iPicture As Picture, iAddress$, iFileName$
        
        Set iList = ActiveWorkbook.Worksheets(1) 'ActiveSheet
        Set iPicture = iList.Pictures(1)
    
        iAddress = iList.Range(iPicture.TopLeftCell, _
        iPicture.BottomRightCell).Address(, , Application.ReferenceStyle)
        iFileName = ActiveWorkbook.Path & "\Picture.html"
    
        With ActiveWorkbook.PublishObjects.Add( _
             xlSourceRange, iFileName, iList.Name, iAddress, xlHtmlStatic)
             .Publish True: .Delete
        End With
        
        ActiveWorkbook.FollowHyperlink Replace(iFileName, ".html", ".files")
    End Sub
    Особенности Microsoft Excel 2007

    В этой версии публикация также возможна, однако, как правило, получить файл, полностью идентичный(размер, расширение), тому, который был импортирован, не получается.
  • Ответ :

    Вариант I.
  • iFilePicture$ = "C:\MyPicture.gif"

    Worksheets(1).Pictures.Insert FileName:=iFilePicture$
    Если необходимо сразу указать нужное месторасположение созданной картинки, а также изменить её размер, то в этом случае, можно воспользоваться свойствами об'екта Picture, например :
    With Worksheets(1).Pictures.Insert(FileName:=iFilePicture$)
         .Top = 50
         .Left = 100
         '.Width = 25
         '.Height = 25
    End With
    Вариант II.
    iFilePicture$ = "C:\MyPicture.jpg"

    Worksheets(1).Shapes.AddPicture _
    FileName:=iFilePicture$, LinkToFile:=False, _
    SaveWithDocument:=True, Left:=100, Top:=50, Width:=25, Height:=25
    Комментарий :
  • cемейство Shapes появилось только в MS Excel 97, поэтому, в MS Excel 95 необходимо использовать первый вариант.
  • первый вариант нельзя использовать, если рабочий лист защищён, т.к. в этом случае Вы получите ошибку. Впрочем, вставить рисунок всё-таки можно, но для этого необходимо, либо снять защиту листу, либо использовать этот совет [FAQ42]
  • второй вариант нельзя использовать, только если рабочий лист защищён в отношении об'ектов.
  • все аргументы метода AddPicture являются обязательными, т.е. при импорте рисунка Вы обязаны указать не только полное имя файла, но и месторасположение картинки, а также её размеры.
    Актуально для MS Excel 2000, XP
    Если же, при вставке картинки, её размеры менять не нужно, то просто укажите ширину и высоту = -1, т.е. Width:=-1, Height:=-1
  • импортировать можно не только файлы с расширением .gif, .jpg, но и .bmp, .png, .wmf и проч.
  • не забывайте перед импортом проверять наличие указанного файла [FAQ44]
  • Ответ :

    Для того, чтобы программно испортировать нужный рисунок из сети интернет, можно использовать любой из двух вышеопубликованных вариантов [FAQ389], только вместо файла, находящегося на диске, укажите реально существующий URL картинки, например :
  • iFilePicture$ = "http://www.msoffice-nm.ru/cat42.jpeg"

  • Ответ :

    Для того, чтобы определить, выделена(активна) диаграмма, или нет, можно использовать такой вариант :
  • If Not ActiveChart Is Nothing Then
       MsgBox "Сейчас выделена(активна) диаграмма " & ActiveChart.Name
    Else
       MsgBox "Сейчас нет выделенной диаграммы"
    End If
    If ActiveChart Is Nothing Then
       MsgBox "Сейчас нет выделенной диаграммы"
    Else
       MsgBox "Сейчас выделена(активна) диаграмма " & ActiveChart.Name
    End If
    Комментарий : VB(A) функция MsgBox и имя диаграммы, используются только для наглядности. В реальности, если Вам необходимо будет обратиться к активной диаграмме, то просто имейте ввиду, что ActiveChart это об'ект Chart. И чтобы понятней было о чём идёт речь, прилагается небольшой пример изменения текста в заголовке активной диаграммы. Если же активная диаграмма не имеет заголовка, то после выполнения нижеопубликованного макроса, он появится автоматически.
    Private Sub SetTextChartTitle()
        If ActiveChart Is Nothing Then Exit Sub
        
        With ActiveChart
             .HasTitle = True
             .ChartTitle.Caption = "Время " & Time
        End With
    End Sub

  • Ответ :

    Для того, чтобы определить верхнюю левую и нижнию правую ячейку, к которым "привязан" определённый графический об'ект, можно использовать свойства TopLeftCell и BottomRightCell, которые возвращают об'ект Range :
  • iLeft = Worksheets(1).DrawingObjects(1).TopLeftCell.Address
    iRight = Worksheets(1).DrawingObjects(1).BottomRightCell.Address
    iLeft = Worksheets(1).Shapes(1).TopLeftCell.Address
    iRight = Worksheets(1).Shapes(1).BottomRightCell.Address
    With Worksheets(1).Shapes(1)
         MsgBox Range(.TopLeftCell, .BottomRightCell).Address
    End With
    Dim iShape As Shape, iLeft As Range, iRight As Range

    Set iShape = Worksheets(1).Shapes(1)
    Set iLeft = iShape.TopLeftCell
    Set iRight = iShape.BottomRightCell

  • Ответ :
  • Private Sub IntersectGraphAndRange()
        Dim iList As Worksheet
        Dim iSource As Range
        Dim iGraph As Object, iCount&
        
        Set iList = Worksheets(1)        'Лист1
        Set iSource = iList.Range("C:C") 'Лист1.[C:C]
        
        For iCount = 1 To iList.DrawingObjects.Count
            Set iGraph = iList.DrawingObjects(iCount)
            
            If Not Intersect(iSource, iList.Range( _
            iGraph.TopLeftCell, iGraph.BottomRightCell)) Is Nothing Then
               MsgBox "Пересеклись", , iGraph.Name
            End If
        Next
    End Sub
    Комментарий :
  • в MS Excel 97 уже можно использовать cемейство Shapes. Однако необходимо помнить, что Shapes, в отличии от DrawingObjects, включает в себя также комментарии и выпадающий список автофильтра, проверки данных и сводной таблицы. A наличие такого выпадающего списка - приведёт к возникновению ошибки, ибо у этого об'екта отсутствуют свойства TopLeftCell и BottomRightCell
  • при переборе элементов семейства DrawingObjects не рекомендую использовать цикл For Each , т.к. в этом случае будут "потеряны" графические элементы некоторых типов.
  • Ответ :

    Для того, чтобы создать копию нужного графического об'екта и сразу указать нужное месторасположение созданной графики, можно воспользовавшись методом Copy скопировать исходный об'ект в буфер обмена, а затем, вставить его используя метод Paste об'екта Worksheet и необязательный именованный аргумент Destination, например :

    Вариант I.
  • With ThisWorkbook.Worksheets(1)
         .Shapes(1).Copy
         .Paste Destination:=.Range("C3")
    End With
    Кроме этого, Вы можете создать копию использовав метод Duplicate, а затем, просто изменить месторасположение копии, воспользоваться свойствами этого об'екта, например :

    Вариант II.
    With ThisWorkbook.Worksheets(1)
         Dim iShape As Shape
         Set iShape = .Shapes(1).Duplicate
         iShape.Top = .Range("C3").Top
         iShape.Left = .Range("C3").Left
    End With
    With ThisWorkbook.Worksheets(1)
         Dim iDestination As Range
         Set iDestination = .Range("C3")
         With .Shapes(1).Duplicate
              .Top =  iDestination.Top
              .Left = iDestination.Left
         End With
    End With
    Комментарий :
  • cемейство Shapes появилось только в MS Excel 97, поэтому, в MS Excel 95 необходимо использовать либо общее семейство DrawingObjects, либо более конкретное, например, Buttons и т.п.
  • оба варианта нельзя использовать, если рабочий лист защищён в отношении об'ектов, т.к. в этом случае Вы получите ошибку. Впрочем, создать копию всё-таки можно, но для этого необходимо, либо снять защиту листу, либо использовать этот совет [FAQ42]
  • если в первом рабочем листе текущей рабочей книги не будет графического об'екта, то любая попытка создать копию, неизменно приведёт к ошибке, которую можно избежать, если предварительно проверить наличие Shape с нужным именем/индексом
  • первый вариант удобен для создания копии в другом рабочем листе
  • последний пример из второго варианта имеет смысл использовать, если Вы собираетесь воспользоваться и другими свойствами и/или методами созданного об'екта и не хотите лишний раз дёргать его (так как это сделано в первом примере)
  • Ответ :

    Для того, чтобы скопировать формат нужного графического об'екта нужно использовать метод PickUp, а для того, чтобы применить его необходимо использовать метод Apply
    Для примера, ниже приведены два варианта, позволяющие скопировать формат первого графического об'екта и применить его ко всем остальным об'ектам активного рабочего листа.

    Вариант I.
  • With ActiveSheet.Shapes
         Select Case .Count
             Case 0: MsgBox "На нет и суда нет", , ""
             Case 1: MsgBox "Хотелось бы побольше графики", , ""
             Case Else: .Item(1).PickUp
             For iCount& = 2 To .Count
                 .Item(iCount&).Apply '
             Next
         End Select
    End With
    Вариант II.
    With ActiveSheet.DrawingObjects
         Select Case .Count
             Case 0: MsgBox "На нет и суда нет", , ""
             Case 1: MsgBox "Хотелось бы побольше графики", , ""
             Case Else: .Item(1).ShapeRange.PickUp
             For iCount& = 2 To .Count
                 .Item(iCount&).ShapeRange.Apply '
             Next
         End Select
    End With

  • Ответ : Скачать пример
  • If Not Worksheets(1).ProtectDrawingObjects Then
       Worksheets(1).DrawingObjects.Delete
    Else
       MsgBox "Удалить сразу все графические об'екты, по всей видимости, нельзя"
    End If
    Примечание : Когда рабочий лист защищён в отношении об'ектов, то удалить сразу все графические об'екты можно только при условии, что все они незащищены, что вряд ли ... ведь защищать лист в отношении об'ектов, без защиты самих об'ектов - не имеет смысла.
  • Ответ :

    Для того, чтобы перебрать все графические об'екты, в т.ч. и OLEObject можно использовать любой из представленных вариантов.

    Вариант I.
  • For iCount = 1 To Worksheets(1).DrawingObjects.Count
        MsgBox Worksheets(1).DrawingObjects(iCount).Name
    Next

    With Worksheets(1).DrawingObjects
         For iCount = 1 To .Count
             MsgBox .Item(iCount).Name
         Next
    End With
    Вариант II.
    Dim iShape As Shape
    For Each iShape In Worksheets(1).Shapes
        MsgBox iShape.Name
    Next
    For iCount = 1 To Worksheets(1).Shapes.Count
        MsgBox Worksheets(1).Shapes(iCount).Name
    Next
    With Worksheets(1).Shapes
         For iCount = 1 To .Count
             MsgBox .Item(iCount).Name
         Next
    End With
    Комментарий :
  • cемейство Shapes появилось только в MS Excel 97, поэтому, в MS Excel 95 необходимо использовать первый вариант.
  • cемейство Shapes, в отличии от DrawingObjects, включает в себя также комментарии, а также выпадающий список автофильтра, проверки данных и сводной таблицы.
  • Ответ :

    Вариант I.
  • Dim iOLEObject As OLEObject
    For Each iOLEObject In Worksheets(1).OLEObjects
        MsgBox iOLEObject.Name
    Next
    Вариант II.
    For iCount = 1 To Worksheets(1).OLEObjects.Count
        MsgBox Worksheets(1).OLEObjects(iCount).Name
    Next
    With Worksheets(1).OLEObjects
         For iCount = 1 To .Count
             MsgBox .Item(iCount).Name
         Next
    End With

  • Ответ : Скачать пример
  • iShapeName = Application.Caller

    MsgBox "Вы только что кликнули : " & iShapeName
    Комментарий : Данный способ не применим к OleObjects, например, ActiveX элементам управления с панели инструментов Элементы управления.
  • Ответ : Скачать пример
  • If Worksheets(1).Shapes(1).Type = msoGroup Then
       MsgBox "Данный об'ект является группой"
    Else
       MsgBox "Данный об'ект не является группированным об'ектом"
    End If
    Bonus : Небольшой пример перебора всех графических об'ектов (в т.ч. и диаграмм) в первом рабочем листе активной рабочей книги, с последующим определением является ли об'ект группой. При наличии группированного об'екта Вы сможете узнать, что именно входит в состав этого об'екта.
    Private Sub AllShapesInWorksheet()

    Dim iShape As Shape, iItem As Shape

    For Each iShape In Worksheets(1).Shapes
        If iShape.Type = msoGroup Then
           If MsgBox("Об'ект «" & iShape.Name & "» является группой" & vbCrLf & _
              "Хотите посмотреть все об'екты этой группы ?", vbYesNo, "") = vbYes Then
              For Each iItem In iShape.GroupItems
                  iGroupItems$ = iGroupItems$ & vbCrLf & iItem.Name
              Next
              MsgBox "Список всех об'ектов : " & iGroupItems$, , ""
              iGroupItems$ = ""
           End If
        Else
           MsgBox "Об'ект «" & iShape.Name & "» не является группой", , ""
        End If
    Next

    End Sub
    Private Sub AllDrawingObjectsInWorksheet()

    With Worksheets(1).DrawingObjects
         Dim iItem As Object
         For iCount& = 1 To .Count
             If .Item(iCount&).ShapeRange.Type = msoGroup Then
                If MsgBox("Об'ект «" & .Item(iCount&).Name & "» является группой" & _
                   vbCrLf & "Хотите посмотреть все об'екты этой группы ?", _
                   vbYesNo, "") = vbYes Then
                   For Each iItem In .Item(iCount&).ShapeRange.GroupItems
                       iGroupItems$ = iGroupItems$ & vbCrLf & iItem.Name
                   Next
                   MsgBox "Список всех об'ектов : " & iGroupItems$, , ""
                   iGroupItems$ = ""
                End If
             Else
                MsgBox "Об'ект «" & .Item(iCount&).Name & "» не является группой", , ""
             End If
         Next
    End With

    End Sub

  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Для автоматического изменения заливки, после изменения данных в нужной ячейки (в данном примере, используется ввод числовых значений) можно воспользоваться событием рабочего листа Worksheet_Change, которое необходимо разместить в модуле рабочего листа, где находится автофигура. А для изменения цвета заливки, можно использовать свойство RGB.
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Not Intersect(Target, [B2]) Is Nothing Then
           If IsNumeric([B2]) = True Then
              Select Case [B2]
                  Case 1 To 100:    iColor& = vbRed
                  Case 100 To 200:  iColor& = vbBlue
                  Case 200 To 300:  iColor& = vbCyan
                  Case 300 To 400:  iColor& = vbGreen
                  Case 400 To 500:  iColor& = vbYellow
                  Case 500 To 1000: iColor& = vbMagenta
                  Case Else:        iColor& = vbWhite
              End Select
              Me.Shapes(1).Fill.ForeColor.RGB = iColor&
           End If
        End If
    End Sub
    Комментарий : Вместо констант допускается использования функции RGB, например, RGB(50, 0, 100)

    Для изменения цвета заливки, также можно использовать свойство SchemeColor.
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Not Intersect(Target, [B2]) Is Nothing Then
           If IsNumeric([B2]) = True Then
              Select Case [B2]
                  Case 1 To 100:    iColor% = 10
                  Case 100 To 200:  iColor% = 12
                  Case 200 To 300:  iColor% = 46
                  Case 300 To 400:  iColor% = 17
                  Case 400 To 500:  iColor% = 34
                  Case 500 To 1000: iColor% = 22
                  Case Else:        iColor% = 65
              End Select
              Me.Shapes(1).Fill.ForeColor.SchemeColor = iColor%
           End If
        End If
    End Sub

  • Ответ : Актуально для MS Excel 97, 2000, XP

    Для автоматического изменения заливки, сразу после активации листа, можно воспользоваться событием рабочего листа Worksheet_Activate, которое необходимо разместить в модуле рабочего листа, где находится автофигура. А для изменения цвета заливки, можно использовать свойство SchemeColor или RGB.
    Цвета, соответствующие дням недели, выбраны исключительно в качестве примера и могут быть изменены.
  • Private Sub Worksheet_Activate()
        Me.Shapes(1).Fill.ForeColor.SchemeColor = _
        Choose(WeekDay(Now, vbMonday), 26, 47, 42, 41, 22, 16, 10)
    End Sub
    Private Sub Worksheet_Activate()
        Me.Shapes(1).Fill.ForeColor.RGB = Choose(WeekDay(Now, _
        vbMonday), 13434879, 10079487, 13434828, 16711680, 16777164, 128, 255)
    End Sub
    Option Base 1

    Private Sub Worksheet_Activate()
        Me.Shapes(1).Fill.ForeColor.SchemeColor = _
        Array(26, 47, 42, 11, 22, 16, 10)(WeekDay(Now, vbMonday))
    End Sub
    Private Sub Worksheet_Activate()
        Me.Shapes(1).Fill.ForeColor.RGB = Array(13434879, 10079487, _
        13434828, 16711680, 16777164, 128, 255)(WeekDay(Now, vbMonday) - 1)
    End Sub
    Примечание : Вместо события Worksheet_Activate() можно использовать макросы, которые выполняются при открытии рабочей книги [FAQ61] Однако, в этом случае, ключевое слово Me необходимо заменить ссылкой на нужный рабочий лист.
  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    1. Создайте графический файл, содержащий изображение графического об'екта, для которого Вы хотите создать всплывающую подсказку. (Если подсказку изначально предполагается создавать для ActiveX элементов управления, то этот пункт можно пропустить)
    2. В меню Вид выберите пункт Панели инструментов и команду Элементы управления. Теперь нажмите кнопку, например, Рисунок (Image) или Надпись (Label) и разместите выбранный элемент управления в нужном месте рабочего листа, при необходимости изменив его размер.
    3. Кликните правой кнопкой мышки и в контекстном меню выберите команду Свойства, затем кликните мышкой небольшую серую кнопку в левой части поля Picture и выберите предварительно созданный графический файл (пункт#1)
    После чего, измените свойства выбранного элемента управления в соответствии с Вашими требованиями. В итоге, Вы должны получить имитацию нужного графического об'екта. (Если подсказку изначально предполагается создавать для ActiveX элементов управления, то этот пункт также можно пропустить)
    4. Нажмите на кнопку Выход из режима конструктора, которая расположена на панели инструментов Элементы управления.
    5. Теперь, в меню Вид выберите пункт Панели инструментов и команду Рисование и выберите нужную фигуру, которая и станет Вашей подсказкой. Разместите выбранный об'ект недалеко от имитации (пункт#3), при необходимости изменив его размер, добавив текст и т.д. и т.п.
    6. Разместите этот код только в модуле книги ThisWorkbook/ЭтаКнига :
  • Private Sub Workbook_Open()
        Application.Run "Restore_UnVisible"
    End Sub
    Этот код разместите в модуле рабочего листа, где находится ActiveX элемент управления :
    Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        If iFlag = False Then
           iFlag = True 'iFlag = Not iFlag
           Me.Rectangles(1).Visible = msoTrue
           Application.OnTime EarliestTime:=DateAdd("s", 1, Now), Procedure:="Restore_UnVisible"
        End If
    End Sub

    Private Sub Worksheet_Activate()
        Application.Run "Restore_UnVisible"
    End Sub
    А затем, разместите в любом стандартном модуле, следующий код :
    Public iFlag As Boolean

    Private Sub Restore_UnVisible()
        iFlag = False
        Лист1.Rectangles(1).Visible = msoFalse
    End Sub
    7. Сохраните все внесённые изменения.

    Примечание :
  • В этом примере, в качестве всплывающей подсказки, используется фигура Прямоугольник с панели инструментов Рисование.
  • В этом примере, подсказка скрывается через одну секунду, но Вы можете откорректировать/изменить это время в соответствии со своими требованиями.
  • Использование стандартного модуля, равно как и кодового (программного) имени листа Лист1, не является обязательным условием.
  • Скрытие подсказки, при открытии и активации рабочего листа, также не является обязательным условием, поэтому, Вы можете скрыть свою подсказку программно и удалить/закомментировать эти события.
  • Если существует вероятность удаления подсказки, в т.ч. и случайной, то перед отображением/скрытием имеет смысл проверить её наличие.
    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

  • © 2004-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff