Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Вставить картинку в Excel " VBA через кнопку" - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставить картинку в Excel " VBA через кнопку" (Макросы/Sub)
Вставить картинку в Excel " VBA через кнопку"
Serega_SS Дата: Четверг, 09.06.2016, 09:05 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010 ; Excel 2016
Добрый день.
Уважаемые специалисты, прошу помогите.
Есть макрос по вставке изображений в Excel через кнопку, но он создает ссылку на картинку, при отправке по почту или открытии на другом компьютере картинки не отображаются!
Если кто то может доработать файл, помогите, необходимо, что-бы вставленное изображение видно было на другом компьютере.
К сообщению прикрепил вложение " макрос работает по нажатию кнопки", использую Excel 2010.
Поглядите, что можно сделать...
Заранее благодарен.
К сообщению приложен файл: 8741087.xlsb(25Kb)
 
Ответить
СообщениеДобрый день.
Уважаемые специалисты, прошу помогите.
Есть макрос по вставке изображений в Excel через кнопку, но он создает ссылку на картинку, при отправке по почту или открытии на другом компьютере картинки не отображаются!
Если кто то может доработать файл, помогите, необходимо, что-бы вставленное изображение видно было на другом компьютере.
К сообщению прикрепил вложение " макрос работает по нажатию кнопки", использую Excel 2010.
Поглядите, что можно сделать...
Заранее благодарен.

Автор - Serega_SS
Дата добавления - 09.06.2016 в 09:05
Manyasha Дата: Четверг, 09.06.2016, 11:04 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1589
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
Serega_SS, вот так попробуйте:
[vba]
Код
    If Application.Dialogs(xlDialogInsertPicture).Show Then
        With Selection
            .Width = 100
        End With
    End If
[/vba]


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеSerega_SS, вот так попробуйте:
[vba]
Код
    If Application.Dialogs(xlDialogInsertPicture).Show Then
        With Selection
            .Width = 100
        End With
    End If
[/vba]

Автор - Manyasha
Дата добавления - 09.06.2016 в 11:04
Roman777 Дата: Четверг, 09.06.2016, 11:13 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 703
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
Serega_SS, тож самое ток чуть-чуть дополнил по-своему:
[vba]
Код
Sub inputPict()
Dim k As Double
If Application.Dialogs(xlDialogInsertPicture).Show Then
   With Selection
      k = .Height / .Width
      .Width = Cells(1, 1).Width * 10 ' привязал ширину картинки к ширине 10 ячеек
      .Height = .Width * k ' высота - сохраняет соотношения сторон картинки
      .Top = Cells(3, 1).Top ' устанавливаю координату по Y
      .Left = Cells(3, 1).Left ' устанавливаю координату по X
   End With
End If
End Sub
[/vba]


Много чего не знаю!!!!
 
Ответить
СообщениеSerega_SS, тож самое ток чуть-чуть дополнил по-своему:
[vba]
Код
Sub inputPict()
Dim k As Double
If Application.Dialogs(xlDialogInsertPicture).Show Then
   With Selection
      k = .Height / .Width
      .Width = Cells(1, 1).Width * 10 ' привязал ширину картинки к ширине 10 ячеек
      .Height = .Width * k ' высота - сохраняет соотношения сторон картинки
      .Top = Cells(3, 1).Top ' устанавливаю координату по Y
      .Left = Cells(3, 1).Left ' устанавливаю координату по X
   End With
End If
End Sub
[/vba]

Автор - Roman777
Дата добавления - 09.06.2016 в 11:13
Serega_SS Дата: Четверг, 09.06.2016, 21:12 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010 ; Excel 2016
Ребят, спасибо огромное, вы реальные мастера! yahoo
 
Ответить
СообщениеРебят, спасибо огромное, вы реальные мастера! yahoo

Автор - Serega_SS
Дата добавления - 09.06.2016 в 21:12
Serega_SS Дата: Четверг, 09.06.2016, 21:37 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010 ; Excel 2016
Возникла проблема, на остальных компьютерах стоит OpenOffice, установить Office 2010 нельзя, есть ли возможность оптимизировать данный файл?
Может сохранить в другом формате, или есть еще варианты?
 
Ответить
СообщениеВозникла проблема, на остальных компьютерах стоит OpenOffice, установить Office 2010 нельзя, есть ли возможность оптимизировать данный файл?
Может сохранить в другом формате, или есть еще варианты?

Автор - Serega_SS
Дата добавления - 09.06.2016 в 21:37
Roman777 Дата: Суббота, 11.06.2016, 21:57 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 703
Репутация: 75 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
Serega_SS, фаил не получится оптимизировать, в openoffice используется, вродебы тот же язык, но синтаксис очень отличается. Макрос, похожий на тот что в 3 сообщении, в OO у меня получился (путём многих проб и ошибок) такой:
[vba]
Код
Sub PicTO()
   Dim document   as object
   Dim dispatcher as object
   Dim oFilePicker As Object
   Dim FileName As String
   Dim sFiles As Object
   Dim size As New com.sun.star.awt.Size
   Dim pos As New com.sun.star.awt.Point
   Dim o as object
   document   = ThisComponent.CurrentController.Frame
   dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
   oFilePicker = CreateUnoService( "com.sun.star.ui.dialogs.FilePicker" )
   If oFilePicker.execute() Then
      sFiles = oFilePicker.getSelectedFiles()
'      Pic = oFilePicker.getFiles()
      FileName=sFiles(0)
   End If
   Dim args1(0) as new com.sun.star.beans.PropertyValue
   args1(0).Name = "ToPoint"
   args1(0).Value = "$A$3"
   dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())
   Dim args2(2) as new com.sun.star.beans.PropertyValue
   args2(0).Name = "FileName"
   args2(0).Value = FileName
'   args2(1).Name = "FilterName"
'   args2(1).Value = "<Все форматы>"
'   args2(2).Name = "AsLink"
'   args2(2).Value = false   
   dispatcher.executeDispatch(document, ".uno:InsertGraphic", "", 0, args2())
   oSheet = thiscomponent.currentcontroller.activesheet
   cell = oSheet.getCellByPosition(0,3)
   dim dx&, dy&, oX&, oY&, cX&, cY&, XkY as double
   cX = cell.Position.X
   cY = cell.Position.Y
   pos.X = cX
   pos.Y = cY
   dx = cell.size.width
   dy = cell.size.height
   objDP = oSheet.DrawPage
   size.Width = dx*10 'ширина картинки - 10 ширин яч.
   For i = 0 to objDP.count-1
      o = objDP.getByIndex(i)
      oX = o.getPosition().X
      oY = o.getPosition().Y
      'почему-то вставляется не ровно по координатам
      if abs(oX-cX)<5 and abs(oY+dy-cY)<5 and o.getShapeType = "com.sun.star.drawing.GraphicObjectShape" then
         XkY = o.getSize().Height/o.getSize().Width
         K =  dx*10*XkY
         size.Height =  dx*10*XkY
         msgbox o.getSize().Width
         o.setSize(size)
         exit for 'если объект (картинка) только один
      end if
   next i
End Sub
[/vba]
Почему-то там вставка и настройка относительно координат идёт всё-таки с погрешностью, в отличии от экселя.


Много чего не знаю!!!!
 
Ответить
СообщениеSerega_SS, фаил не получится оптимизировать, в openoffice используется, вродебы тот же язык, но синтаксис очень отличается. Макрос, похожий на тот что в 3 сообщении, в OO у меня получился (путём многих проб и ошибок) такой:
[vba]
Код
Sub PicTO()
   Dim document   as object
   Dim dispatcher as object
   Dim oFilePicker As Object
   Dim FileName As String
   Dim sFiles As Object
   Dim size As New com.sun.star.awt.Size
   Dim pos As New com.sun.star.awt.Point
   Dim o as object
   document   = ThisComponent.CurrentController.Frame
   dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
   oFilePicker = CreateUnoService( "com.sun.star.ui.dialogs.FilePicker" )
   If oFilePicker.execute() Then
      sFiles = oFilePicker.getSelectedFiles()
'      Pic = oFilePicker.getFiles()
      FileName=sFiles(0)
   End If
   Dim args1(0) as new com.sun.star.beans.PropertyValue
   args1(0).Name = "ToPoint"
   args1(0).Value = "$A$3"
   dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())
   Dim args2(2) as new com.sun.star.beans.PropertyValue
   args2(0).Name = "FileName"
   args2(0).Value = FileName
'   args2(1).Name = "FilterName"
'   args2(1).Value = "<Все форматы>"
'   args2(2).Name = "AsLink"
'   args2(2).Value = false   
   dispatcher.executeDispatch(document, ".uno:InsertGraphic", "", 0, args2())
   oSheet = thiscomponent.currentcontroller.activesheet
   cell = oSheet.getCellByPosition(0,3)
   dim dx&, dy&, oX&, oY&, cX&, cY&, XkY as double
   cX = cell.Position.X
   cY = cell.Position.Y
   pos.X = cX
   pos.Y = cY
   dx = cell.size.width
   dy = cell.size.height
   objDP = oSheet.DrawPage
   size.Width = dx*10 'ширина картинки - 10 ширин яч.
   For i = 0 to objDP.count-1
      o = objDP.getByIndex(i)
      oX = o.getPosition().X
      oY = o.getPosition().Y
      'почему-то вставляется не ровно по координатам
      if abs(oX-cX)<5 and abs(oY+dy-cY)<5 and o.getShapeType = "com.sun.star.drawing.GraphicObjectShape" then
         XkY = o.getSize().Height/o.getSize().Width
         K =  dx*10*XkY
         size.Height =  dx*10*XkY
         msgbox o.getSize().Width
         o.setSize(size)
         exit for 'если объект (картинка) только один
      end if
   next i
End Sub
[/vba]
Почему-то там вставка и настройка относительно координат идёт всё-таки с погрешностью, в отличии от экселя.

Автор - Roman777
Дата добавления - 11.06.2016 в 21:57
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Вставить картинку в Excel " VBA через кнопку" (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!