Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)
-   -   [решено] Макрос для приведения к одному, одинаковому размеру графиков (http://forum.oszone.net/showthread.php?t=248819)

Invincible 10-12-2012 17:40 2042546

Макрос для приведения к одному, одинаковому размеру графиков
 
Подскажите макрос для приведения к одному, одинаковому размеру всех графиков.
Или какой-нибудь другой способ как это можно сделать

okshef 10-12-2012 20:22 2042678

Invincible, еще бы знать, какое приложение вы имеете в виду?

Для Word: Как моментально изменить масштаб всех картинок в документе Word

Iska 10-12-2012 20:27 2042682

Откуда брать этот «один, одинаковый размер»? Вариант «настроить как образец размеры одного графика, выделить его, вызвать макрос» — устроит?

okshef, я ж помню, что было. А вот не нашёл :(. Это не совсем то.

Invincible 10-12-2012 21:22 2042713

Цитата:

Цитата Iska
Откуда брать этот «один, одинаковый размер»? Вариант «настроить как образец размеры одного графика, выделить его, вызвать макрос» — устроит? »

Да, если можно

Iska 10-12-2012 22:23 2042741

Invincible, что с этим вопросом:
Цитата:

Цитата okshef
Invincible, еще бы знать, какое приложение вы имеете в виду? »

Вот пример макроса для любых объектов (не только графиков), расположенных в тексте документа Microsoft Word:
Код:

Option Explicit

Sub Sample()
    Dim objInlineShapeMaster As InlineShape
    Dim objInlineShape As InlineShape
   
    If Selection.Type = wdSelectionInlineShape Then
        Set objInlineShapeMaster = Selection.InlineShapes.Item(1)
       
        For Each objInlineShape In ActiveDocument.Content.InlineShapes
            With objInlineShape
                .LockAspectRatio = msoTrue
                .Height = objInlineShapeMaster.Height
                .Width = objInlineShapeMaster.Width
            End With
        Next
       
        Set objInlineShapeMaster = Nothing
    Else
        MsgBox "Not a InlineShape in Selection", vbCritical + vbOKOnly, "Error"
    End If
End Sub

Если укажете как и чем были сделаны графики, можно подумать об отделении их от прочих объектов.

Invincible 10-12-2012 23:15 2042766

Цитата:

Цитата Iska
Если укажете как и чем были сделаны графики, можно подумать об отделении их от прочих объектов. »

Графики строил в Excel, обычные гистограммы и диаграммы

Iska 11-12-2012 23:28 2043504

Invincible, можете упаковать пример файла в архив, выложить на обменник, а ссылку — сюда или в личку?

Invincible 23-12-2012 22:44 2051950

Цитата:

Цитата Iska
можете упаковать пример файла в архив, выложить на обменник, а ссылку — сюда или в личку? »

http://rusfolder.com/34252389

okshef 23-12-2012 22:57 2051966

Код:

ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Width = 283
Selection.ShapeRange.Height = 170

Значения Width и Height подбирайте сами.

Invincible 18-01-2013 00:56 2069221

Имею, такой макрос
Цитата:

Цитата okshef
Значения Width и Height подбирайте сами. »

Как можно сделать, чтобы значение предлагалось ввести пользователю, то есть мне по нажатии на кнопку в меню надстройки?
Чтобы не бегать постоянно в разработчик и там менять значения

http://rusfolder.com/34567895

Invincible 25-01-2013 00:28 2074374

Сделал так
Код:

Sub Get_Graphics()
    On Error Resume Next: Err.Clear
    Dim ChrtObj As ChartObject, w&, h&
    ' запрашиваем у пользователя высоту и ширину
    w& = InputBox("Введите ширину для диаграмм", , 300): If Err Then Exit Sub
    h& = InputBox("Введите высоту для диаграмм", , 200): If Err Then Exit Sub

    Application.ScreenUpdating = False
    For Each ChrtObj In ActiveSheet.ChartObjects
        ChrtObj.Height = h&
        ChrtObj.Width = w&
    Next
End Sub

А можно использовать данный макрос в Microsoft Office Power Point?

Invincible 06-02-2013 22:18 2084051

Код:

Sub test2() 
Dim sh As Shape, ActiveSlide As Slide, w As Long, h As Long  On Error Resume Next: Err.Clear   
Set ActiveSlide = ActiveWindow.Selection.SlideRange(1) 
h = InputBox("Height", , 200): If Err Then Exit Sub 
w = InputBox("Width", , 300): If Err Then Exit Sub   
For Each sh In ActiveSlide.Shapes     
f sh.Type = msoChart Then         
sh.Height = h         
sh.Width = w     
End If  Next  End Sub



Время: 10:51.

Время: 10:51.
© OSzone.net 2001-