blue021433
Altın Üye
- Katılım
- 21 Şubat 2007
- Mesajlar
- 24
- Excel Vers. ve Dili
- Office Professional Plus 2019 Türkçe
- Altın Üyelik Bitiş Tarihi
- 11-01-2025
Merhaba Arkadaşlar.
Makro ile hücreye çift tıkladığım zaman resim ekleme yapabiliyorum.
Fakat hücrelere bu yöntemle resim eklediğim zaman başka bilgisayarda bu resimler görüntülenemiyor.
İstediğim şey resimlerin excele gömülü kalması.
Kullanılan kod aşağıda ki gibidir.
Sizlerin önerebileceği yeni kod varsa seve seve kullanırım
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 0).MergeArea.Height - 0.2
.Width = Target.Offset(0, 0).MergeArea.Width - 0.2
.Top = ActiveCell.Top + 0.2
.Left = ActiveCell.Left + 0.2
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Range("F1").Select
End Sub
Makro ile hücreye çift tıkladığım zaman resim ekleme yapabiliyorum.
Fakat hücrelere bu yöntemle resim eklediğim zaman başka bilgisayarda bu resimler görüntülenemiyor.
İstediğim şey resimlerin excele gömülü kalması.
Kullanılan kod aşağıda ki gibidir.
Sizlerin önerebileceği yeni kod varsa seve seve kullanırım
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Target.Offset(0, 0).MergeArea.Height - 0.2
.Width = Target.Offset(0, 0).MergeArea.Width - 0.2
.Top = ActiveCell.Top + 0.2
.Left = ActiveCell.Left + 0.2
.Placement = xlMoveAndSize
End With
Set pic = Nothing
Range("F1").Select
End Sub
Son düzenleme: