Вставка картинки реальных размеров или хотябы в пропорции

[Mbus]

Здравствуйте!

    
Dim fn As String
Dim h As Double
Dim v As Double

fn =  "C:\1.png"
h = ActiveCell.Left
v = ActiveCell.Top
    
ActiveWorkbook.ActiveSheet.Shapes.AddPicture fn, False, True, h, v, 30, 30

Картинка вставляется конечно.
Но вот мне нужно чтобы она вставлялась со своими реальными размерами, а не теми которые нужно указать в AddPicture (картинки разные, вытянутые, приплючнутые и т.д. и вставлять их под одну гребенку неправильно).

Как вытащить реальные размеры картинки и назначить их ей?



=============== комментарий модератора ====================

У меня на сайте есть готовая программа для вставки изображений на лист Excel:
http://excelvba.ru/programmes/PastePictures
Там берутся реальные размеры картинки (и, при необходимости, картинка масштабируется с соблюдением пропорций)

Надстройка позволяет искать в выбранной папке изображения, основываясь на содержимом ячеек таблицы Excel, и производить вставку найденных изображений в соседние ячейки (или в примечания к этим ячейкам).

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




Особенности надстройки вставки изображений:

• загрузка изображений по ссылкам (обычная гиперссылка, просто текст ссылки - URL, формула =ГИПЕРССЫЛКА(), и т.п.)
• поиск картинок в подпапках заданной папки (глубина поиска по подпапкам не ограничена)
• установка выбранного пользователем размера для вставляемых изображений
• отображение состояния поиска и вставки изображений (прогресс-бар)
• вывод результатов обработки таблицы (сколько изображений вставлено, сколько не найдено)
• добавление гиперссылок к вставляемым изображениям (по щелчку на картинке открывается исходный файл)
• 2 режима поиска файлов - по точному совпадению имени файла, и по началу имени файла-изображения
• 2 режима вставки картинок - подгонка размеров под ячейку, или соблюдение пропорций исходного изображения
• вывод количества файлов в выбранной папке
• возможность выбора столбца с названиями файлов, и указания номера столбца для вставляемых изображений
• возможность вставки изображений в комментарии к ячейкам

Запуск вставки изображений выполняется из меню программы (на панели инструментов)

Надстройка вставки картинок в Excel теперь поддерживает обновления - поэтому отныне надстройка будет регулярно получать новые полезные функции.

Новый функционал будет добавляться в надстройку по мере поступления ваших пожеланий.

[IgorGO]

вообще-то вам предстоит разобрать формат разных графических файлов. я когда-то разобрался только с форматом несжатого ".bmp". ниже фрагмент кода, начинается с выбора файла, включает проверку что это bmp и он несжат, в переменных W и H считаны, соответсвенно, ширина и высота картинки.

Sub InsPicture()
Dim fn As String, W As Long, H As Long, w1 As Integer, dof As Long, bpp As Integer, sz As Long
Dim r As Long, p As Long, Ln As Long, BMP As Boolean, bt As Byte
Dim rc As Byte, gc As Byte, bc As Byte
  With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Выбери файл, или откажись от этой затеи"
    .Filters.Add "BitMap", "*.bmp"
    .AllowMultiSelect = False
    If .Show = -1 Then fn = .SelectedItems(1) Else Exit Sub
  End With
  Open fn For Random As #1 Len = 1
    Get #1, 1, bt: BMP = bt = 66
    Get #1, 2, bt: If BMP Then BMP = bt = 77
  Close #1
  If Not BMP Then MsgBox "Закрываемся... Не BMP-файл.": Exit Sub
  bpp = ReadNB(fn, 2, 29)
  If bpp <> 24 Then MsgBox "Закрываемся... Конвертируйте ваш файл каким-нибудь графическим редактором в 24-битный имидж.": Exit Sub
  dof = 1 + ReadNB(fn, 4, 11)
  W = ReadNB(fn, 4, 19):  H = ReadNB(fn, 4, 23)
End Sub


Function ReadNB(s As String, N As Byte, of As Long) As Long
Dim b As Byte, i As Byte, r As Long
  Open s For Random As #1 Len = 1
    r = 0
    For i = 0 To N - 1
      Get #1, of + i, b
      r = r + b * 2 ^ (8 * i)
    Next
  Close #1
  ReadNB = r
End Function

[Mbus]

спасибо.
Я уж тоже начала об этом задумываться, как вытащить размеры из самого файла *.png.

[Mbus]

На другом форуме еще вот такой вариант предложили, только не идет с картинками формата *.png.

Из справки вот с этими форматами должно срабоать:
*.bmp
*.cur
*.gif
*.ico
*.jpg
*.wmf

Const P = 26.458
Dim x As IPictureDisp
Dim fn As String
Dim h As Double
Dim v As Double

fn = "C:\1.gif"
Set x = LoadPicture(fn)
A = CInt(x.Width / P)
b = CInt(x.Height / P)
h = ActiveCell.Left
v = ActiveCell.Top
ActiveWorkbook.ActiveSheet.Shapes.AddPicture fn, False, True, h, v, A, b

[Afetk]

А не пробывали

1)закрепляет соотношение сторон
Selection.ShapeRange.LockAspectRatio = msoTrue

2)Определяет размер картинки по высоте
(например 70
при этом можно предварительно подогнать высоту
"Selection.RowHeight = 75"
и отступить от линии ячейки
"Selection.ShapeRange.Increment Top 3" )
Selection.ShapeRange.Height = 70# (определить высоту картинки)


Sub InsertPicture1()
Dim h, h1, h2, v, v1, v2 As Double

i = Selection.Row
' у меня в первой колонке имя файла
cells(i, 1).Select
' определяем фильтр
FName = Application.GetOpenFilename("Pictur e (*.png;*.jpg),*.png;*.jpg")

Selection.RowHeight = 75
' мне мне надо сдвинуть привязку картинки относительно первого столбца на 26 колонок
h1 = ActiveCell(0, 26).Left
h2 = ActiveCell.ColumnWidth
h = h1 - h2

v1 = ActiveCell.Top
v2 = ActiveCell.Height - 1
v = v1 - v2

PikName = ActiveCell.Value

ActiveSheet.Pictures.Insert(FName). Select
Selection.ShapeRange.IncrementLeft h
Selection.ShapeRange.IncrementTop v
Selection.ShapeRange.LockAspectRati o = msoTrue
Selection.ShapeRange.Height = 70#
Selection.Name = PikName + "Small"
Selection.ShapeRange.PictureFormat. ColorType = msoPictureAutomatic

With Selection

.Placement = xlMove
.PrintObject = True
End With
' выбираем следующую ячейку
cells(i + 1, 1).Select

End Sub

безусловно его можно подчистить и кое где подправить ...