VBA Tools

Chcesz osadzić grafikę w komórce?

Założeniami jest, aby grafika była zwymiarowana dokładnie jak cela obok. Procedura zadziała dla zaznaczonego obszaru komórek, który będzie zawierał nazwę plików dla każdej z celi z osobna. Zdjęcia będą pobierane z jednego katalogu.

Option Explicit
'MVP OShon from VBATools.pl
Sub Wstaw_fote_do_celi_obok()
Dim Filename$, place As Range, myPic As Object, kom$
For Each place In Selection
kom = place.Offset(, 1).Address
Filename = "c:\Temp\" & place
If FileExists(Filename) = True Then
 Set myPic = ActiveSheet.Pictures.Insert(Filename)
 With myPic
 .Top = Range(kom).Top
 .Left = Range(kom).Left
 .ShapeRange.LockAspectRatio = msoFalse
 .ShapeRange.Height = Range(kom).RowHeight
 .ShapeRange.Width = Range(kom).Width
 End With
End If
Next
Set myPic = Nothing
End Sub
Public Function FileExists(FilePath As String) As Boolean
On Error GoTo blad
 FileExists = Len(Dir(FilePath, vbDirectory Or vbHidden Or vbSystem)) > 0
Exit Function
blad:
FileExists = False
End Function

Efekt można przedstawić następująco:

W przypadku braku rozszerzenia w nazwach komórek możemy podać go w zmiennej:

If FileExists(Filename & ".jpg") = True Then
 Set myPic = ActiveSheet.Pictures.Insert(Filename & ".jpg")

Jeszcze jednym pomysłem do wykorzystania jest kompresja obrazków, jendakże dostęp do tej opcji można uzyskac poprzez automatyzację:

Dim Kompresja As CommandBarControl
Set Kompresja = Application.CommandBars.FindControl(ID:=6382)
 Application.SendKeys "%e~"
 Application.SendKeys "%a~"
 Kompresja.Execute
Set Kompresja = Nothing

Procedura przygotowana i testowana w 2007

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.