Добрый день. Уважаемые специалисты, прошу помогите. Есть макрос по вставке изображений в Excel через кнопку, но он создает ссылку на картинку, при отправке по почту или открытии на другом компьютере картинки не отображаются! Если кто то может доработать файл, помогите, необходимо, что-бы вставленное изображение видно было на другом компьютере. К сообщению прикрепил вложение " макрос работает по нажатию кнопки", использую Excel 2010. Поглядите, что можно сделать... Заранее благодарен.
Добрый день. Уважаемые специалисты, прошу помогите. Есть макрос по вставке изображений в Excel через кнопку, но он создает ссылку на картинку, при отправке по почту или открытии на другом компьютере картинки не отображаются! Если кто то может доработать файл, помогите, необходимо, что-бы вставленное изображение видно было на другом компьютере. К сообщению прикрепил вложение " макрос работает по нажатию кнопки", использую Excel 2010. Поглядите, что можно сделать... Заранее благодарен.Serega_SS
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
Возникла проблема, на остальных компьютерах стоит OpenOffice, установить Office 2010 нельзя, есть ли возможность оптимизировать данный файл? Может сохранить в другом формате, или есть еще варианты?
Возникла проблема, на остальных компьютерах стоит OpenOffice, установить Office 2010 нельзя, есть ли возможность оптимизировать данный файл? Может сохранить в другом формате, или есть еще варианты?Serega_SS
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