Soru Makrolu fotoğraf yüklediğim dosya başka bilgisayarda açılmıyor.

[enkorkmaz]

Merhabalar,
Hazırladığım excel sayfasında yaklaşık 500 adet ürün var. Ve hepsinin birer kodu ve fotoğrafı mevcut. Excel vba ile liste oluşturdum. Sayfaya çağırdığım fotoğrafları üst-alt-sağ ve soldan hücrelere sığdırdım. Buraya kadar tamam. Buradan sonra 2 problem ile karşılaşıyorum. 1- Hazırlanmış olan dosya, başka bilgisayara gönderildiğinde fotoğraflar açılmıyor. 2- Sayfa 1 de olan ürünlerin kodlarını kopyala yapıştır yaptığımda, örneğin 3. sırada bulunan ürünün fotoğrafı yok. Ondan sonra gelen ürünlerin fotoğrafları olduğu halde hiçbirinin fotoğrafı açılmıyor.
Yardımlarınız için şimdiden teşekkür ederim.


Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [a:a]) Is Nothing Then Exit Sub

'hata kontrolü
On Error GoTo çıkış
' Resimleri Sil

ActiveSheet.DrawingObjects.Delete
'Resim yolunun bulunması

Dim ResimYolu As Variant
Dim Resim As Object

For satır = 2 To 500

ResimYolu = ActiveWorkbook.Path & "\" & Range("a" & satır) & ".png"

' Resmi oluştur

' Resmi oluştur
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

'Resmi Boyutlandır

Set ImageCell = Range("b" & satır).MergeArea

With Range("b" & satır)
Resim.ShapeRange.LockAspectRatio = msoFalse
Resim.Top = ImageCell.Top
Resim.Left = ImageCell.Left
Resim.Height = ImageCell.Height
Resim.Width = ImageCell.Width
End With

Next satır

çıkış:
End Sub

 

[a_self_lion]

Bununla ilgili bir çözüm üreten oldu mu arkadaşlar

 

[Korhan Ayhan]

Merhaba,

Faydalı olabilir..

MACRO ile excele çekilen resimler Başka Pcde gözükmüyor

kolay gelsin. bu forumdan öğrendiğim bir makro ile bilgisayarımdan excele satırın içine tam sığan fotoğraflar yüklüyorum ama dosyayı kaydedip başka birine gönderdiğimde resim görüntülenemiyor silinmiş taşınmış olabilir gibi şeyler söylüyor. resimlerimin bağlantılı değil de direk excel dosyasına...

www.excel.web.tr

 

[nihatkr]

Excel dosyanızla resimlerin olduğu klasörü aynı şekilde diğer bilgisayarada taşırsanız çözülür diye düşünüyorum.

....\belgeler\proje\dosya.xls

yada
NOT: DOSYANIZIN YEDEĞİNİ ALDIKTAN SONRA DENEYİN


her bilgisayar değiştiğinizde yolu sorsun.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim satır As Long
Dim ResimYolu As String
Dim Resim As Shape
Dim ImageCell As Range
Static ResimKlasoru As String

If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub

If ResimKlasoru = "" Then
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Resimlerin bulunduğu klasörü seçin"
If .Show = -1 Then
ResimKlasoru = .SelectedItems(1)
Else
MsgBox "Resim klasörü seçilmedi. İşlem iptal edildi.", vbExclamation
Exit Sub
End If
End With
End If

On Error GoTo çıkış

For Each Resim In Me.Shapes
If Not Intersect(Resim.TopLeftCell, Me.Range("B:B")) Is Nothing Then
Resim.Delete
End If
Next Resim

For satır = 2 To 500
If Me.Range("A" & satır).Value <> "" Then
ResimYolu = ResimKlasoru & "\" & Me.Range("A" & satır).Value & ".png"

If Dir(ResimYolu) <> "" Then

Set ImageCell = Me.Range("B" & satır).MergeArea

Set Resim = Me.Shapes.AddPicture( _
Filename:=ResimYolu, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoCTrue, _
Left:=ImageCell.Left, _
Top:=ImageCell.Top, _
Width:=ImageCell.Width, _
Height:=ImageCell.Height)

Resim.LockAspectRatio = msoFalse
End If
End If
Next satır

çıkış:
End Sub