Resim ekleme kodu revize hakkında

[kakara]

merhaba ustadlar assagıdakı kod ıle resım cekmeye calısıyorum fakat basaramadım. bırde resım yolunu değiştirmek için ne yapmam gerekıyor. ilginiz için şimdiden teşekkurler



Sub Resim_Ekle()
Application.Volatile
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim fso As Object, Evn As Object, renk As Byte, mypicture As Shape
Set Evn = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each i In ActiveSheet.Shapes
If i.Name <> "Picture 22" Then
If i.Name Like "Pic*" Then
ActiveSheet.Shapes(i.Name).Delete
End If
End If
Next i
Range("A:A").UnMerge
Range("N:N").ClearContents
Rows.RowHeight = 15
dip = Cells(Rows.Count, "C").End(3).Row
Range("A2:M" & dip).Borders.LineStyle = xlNone
Range("N2").FormulaLocal = "=EĞERSAY($C$2:$C$" & dip & ";C2)"
Range("N2:N" & dip).FillDown
For a = 2 To Range("C65536").End(3).Row
If Not Evn.exists(Cells(a, 3).Value) Then
Randomize
If Cells(a, "N") = 1 Then
Rows(son + 1 & ":" & son + 1).RowHeight = 90 / Cells(son + 1, "N").Value
End If
If son <> Empty Then
If son > 1 And Cells(ilk, "N").Value <> 1 Then
Range("A" & ilk & ":A" & son).Merge
Rows(ilk & ":" & son).RowHeight = 90 / Cells(ilk, "N").Value
End If
End If
ilk = a
Evn.Add Cells(a, 3).Value, 1
Else
son = a
End If
Next a
Range("A2:M" & dip).Borders.LineStyle = 1

For i = 2 To Range("B65536").End(3).Row
For Each resim In fso.getfolder(ThisWorkbook.Path & "/resim").Files
foto = Split(resim.Name, " ")(0)
If Cells(i, "B").RowHeight > 0 Then
If Split(Cells(i, "C").Value, " ")(0) = foto Then
c = c + 1
Cells(i, "O").Value = "OK"
Set fotom = ActiveSheet.Pictures.Insert(CStr(resim))
With fotom
.ShapeRange.LockAspectRatio = msoFalse
.Width = Cells(i, "A").Width
.Height = Range("A" & i & ":A" & (i + Cells(i, "N").Value) - 1).Height
.Top = Rows(Cells(i, 1).Row).Top
.Left = Columns(Cells(i, 1).Column).Left
.Placement = xlFreeFloating
End With
i = i + Cells(i, "N").Value - 1
Exit For
End If
End If
Next resim
10 Next i
Range("N:O").Clear
Application.EnableEvents = True
Application.ScreenUpdating = True
i = Empty: Set Evn = Nothing
End Sub

 

[Korhan Ayhan]

Bu tarz sorularınızda örnek dosya ve birkaç resim dosyası paylaşırsanız yardım etmek isteyenlerin deneme yapma fırsatı olur.

 

[Korhan Ayhan]

Ek olarak konu başlıklarında "kod revize" "formül hakkında" gibi genel başlıklar yerine konu içeriğini özetleyecek şekilde başlıklar tercih ediniz.

 

[kakara]

merhaba @Korhan Ayhan ustadım öncelıkle baslıgı yanlıs actıgım ıcın kusura bakmayın ve ilgilenip bilgilendirdiğiniz için teşekkur ederım.
dosyamı ekledım ıstedıgım ıse makronun ıcınde ürünlerın fotograflarını çekıcek dosya yolunu ben vermek ıstıyorum kodda nasıl bır değişiklik yapılması gerekıyor ve zahmet olmassa nereye dosya yolu gırecegımı belırtebılır mısınız ? şimdiden ilginize teşekkur ederım

 

[muysun35]

For Each resim In fso.getfolder(ThisWorkbook.Path & "/resim").Files

bu alanda değişiklik yapın. Şu anda excel dosyasının bulunduğu dizindeki resim adlı klasörün içindeki dosyalar verilmiş yol olarak

mesela

For Each resim In fso.getfolder("c:\excelcalismam\resimklasoru").Files

gibi
bu da C sürücüsündeki excelcalismam klasörünün içindeki resimklasoru içindeki dosyalarla işlem yapmanızı sağlar.

 

[kakara]

@muysun35 ustadım ben fimadaki ağın ıcınden almam gerekıyor fotoları yanı c: sürücüsü değilde "\\10.0.0.9\deporesim\" bu ağdan almam gerekıyor c: yerıne "\\10.0.0.9\deporesim\" agın adresını yazsam yeterlı olur mu acaba ?

 

[kakara]

dediğiniz değişikliği yapıp denedım c: yerıne \\10.0.0.9\deporesim\ adresı yazdım fakat excel kitlendi : ) ustadım

 

[kakara]

sorun devam etmekte yardımcı olacaklara sımdıden tesekkurler

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Bu kod ile ilgili klasöre erişiminiz var mı kontrol ediniz.

Option Explicit

Sub Test()
    Dim Dosya
    Dosya = Dir("\\10.0.0.9\deporesim\*.*")
    MsgBox Dosya
End Sub

 

[kakara]

@Korhan Ayhan ustadım verdıgınız kodu denedım bır msj box geldı. zaten ılgılı klasöre erişimim var hali hazırda farklı bır makroyla ordan resım cekebılıyorum

 

[Korhan Ayhan]

Msgbox'ta dosya adı görebildiniz mi?

 

[kakara]

0010011237.jpg dıye geldı @Korhan Ayhan ustadım

 

[Korhan Ayhan]

Tamam..

Aşağıdaki döngüyü iptal edip;
For Each resim In fso.getfolder(ThisWorkbook.Path & "/resim").Files

Yerine Dir-While-Wend döngüsü kurmayı deneyiniz. Forumda örnekleri var. Arama yaparsanız ulaşabilirsiniz.

 

[kakara]

tesekkurler @Korhan Ayhan ustadım bıraz kurcalıyayım