resim boyutu ayarlama

[hamza02]

Arkadaşlar herkese merhaba, aranıza yeni katıldım. yardımlarınız için şimdiden teşekkürler.

Aşağıdaki kod içinde Sayfa3 D5 hücresindeki resmin boyutunu ayarlamak istiyorum.




Private Sub ComboBox1_Change()

Sayfa3.Range("B2").Value = ComboBox1.Text 'B2 hücresine ComboBox ile Seçilen ÜRÜN ADI'nı yazar
Sayfa3.Range("B3") = WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:B1000"), 2, 0) 'B3 hücresine ÖLÇÜ BİRİMİ getirir
Sayfa3.Range("C3") = WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:C1000"), 3, 0) 'C3 hücresine FİYAT getirir
Sayfa3.Range("B5") = "BİRİM FİYAT : " & Sayfa3.Range("C3") & " / " & Sayfa3.Range("B3") 'B6 hücresine BİRİM FİYAT ı getirir
Sayfa3.Range("B6") = "ÜRETİM YERİ : " & WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:E1000"), 5, 0) 'B6 hücresine ÜRETİM YERİ ni getirir
Sayfa3.Range("B7") = "FİYAT DEĞİŞİM TARİHİ : " & Format(WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A2:F1000"), 6, 0), "dd.mm.yyyy") 'B6 hücresine FİYAT DEĞİŞİM TARİHİ ni getirir
Sayfa3.Range("C10") = WorksheetFunction.VLookup(Sayfa3.Range("B2"), Sayfa1.Range("A21000"), 4, 0) 'B6 hücresine YERLİ - İTHAL bilgisini getirir

'HÜCRE İÇİNDEKİ RESMİ SİLER-1
With ActiveSheet
For Each Sh In .Shapes
If Not Application.Intersect(Sh.TopLeftCell, .Range("D5")) Is Nothing Then Sh.Delete
Next Sh
End With

If Sayfa3.Range("C10") = "Yerli" Then
Sayfa3.Range("P2").Copy Sayfa3.Range("D5")
End If

Sayfa3.Activate
Sayfa3.Range("D6").Select
Sayfa3.Range("D6").Copy
Sayfa3.Range("D5").PasteSpecial Paste:=xlPasteFormats
Sayfa3.Range("G2").Select
Sayfa3.Range("G2").Clear

Sayfa3.Range("G2").Select

End Sub

 

[hamza02]

arkadaşlar size zahmet yardımcı olursanız sevinirim biraz acilde

 

[Cengiz Demir]

Bu kodlar işinizi görür sanırım. D5 hücre iboyutuna göre resmi boyutlandırır.

Yanlız sayfa3 de birden fazla resim varsa; D5 deki resim seçip, excelde sol üstte hücre referanslarının gösterildiği kutucuktan resim ismine bakın.
Orda Resim 1 Resim 2 vb.. yazması lazım.
Bu koddaki 1'i orda yazan numaraya göre değiştirin.
Sayfa3.Shapes(1)

    picLeft = Sayfa3.Range("D5").Left + 1
    picTop = Sayfa3.Range("D5").Top + 1
    picWidth = Sayfa3.Range("D5").Width - 2
    picHeight = Sayfa3.Range("D5").Height - 2
       
    With Sayfa3.Shapes(1)
    .LockAspectRatio = msoFalse
    .Left = picLeft
    .Top = picTop
    .Height = picHeight
    .Width = picWidth

 

[Cengiz Demir]

Yukarıda çıkmamış. En alta
End with
satırını ekleyin.

 

[hamza02]

Sayın cengizdemir72 öncelikle yardımınız için teşekkür ederim. Ancak bu kodlar işime yaramadı çünkü resim adı değişiyor.

 

[hamza02]

Dediğiniz doğru sayfada birden fazla resim var, combobox ile ürün adı seçiyorum seçilen ürün yerli malı ise D5 hücresine yerli malı logosu ekliyor ithal ürün ise logoyu siliyor ve kayıt sayfasında yüzlerce ürün var

 

[Cengiz Demir]

O zaman başka bir üstad yardımcı olabilir sanırım.
D5 hucresindeki resim adını yada idsini öğrenebilecek bir kod yazabilirlerse shape(1) ona göre ayarlanır ve doğru resim seçilmiş olur.

 

[Cengiz Demir]

Biraz araştırdım. Bu kodlar işinizi görür sanırım. Range("A":Y1048576") alanını kendinize göre uyarlarsınız.

Sub Resim()


   Dim Resim As Picture, Alan As Range
    
    Set Alan = Sheets("Sayfa3").Range("A1:Y1048576")
    
    For Each Resim In ActiveSheet.Pictures
    Sat = Resim.TopLeftCell.Row
    Sut = Resim.TopLeftCell.Column
    
    If Sat = 5 And Sut = 4 Then
        picLeft = Sheets("Sayfa3").Range("D5").Left + 1
        picTop = Sheets("Sayfa3").Range("D5").Top + 1
        picWidth = Sheets("Sayfa3").Range("D5").Width - 2
        picHeight = Sheets("Sayfa3").Range("D5").Height - 2
        isim = Resim.Name
                
        With Sheets("Sayfa3").Shapes(isim)
        .LockAspectRatio = msoFalse
        .Left = picLeft
        .Top = picTop
        .Height = picHeight
        .Width = picWidth
        End With
     End If
        
    Next
    
Set Alan = Nothing

End Sub

 

[hamza02]

Sayın cengizdemir72 hocam ilginize tekrar teşekkür ederim.
kodları denedim ama hata verdi bir türlü başaramadım muhtemelen bende kaynaklı sanırım, buraya excel dosyası nasıl ekleyebilirim acaba.

 

[Cengiz Demir]

Sayın hamza02. rica ederim
Dosya.tc vb. gibi dosya ekleme sitelerine ekleyip, linkini koyabilirsiniz.

Yukarıdaki kodları Sub Resim() ve en alttaki End Sub olmadan, makronuzdaki aşağıda belirttiğim iki satırın arasına ekleyip dener misiniz ?

Olmazsa dosyayı eklediğinizde ben bakabilirim.

Sayfa3.Range("D5").PasteSpecial Paste:=xlPasteFormats

Kodlar buraya.......

Sayfa3.Range("G2").Select

Sayın cengizdemir72 hocam ilginize tekrar teşekkür ederim.
kodları denedim ama hata verdi bir türlü başaramadım muhtemelen bende kaynaklı sanırım, buraya excel dosyası nasıl ekleyebilirim acaba.

 

[Orion1]

Makro kaydet ile gerekli kodları yazabilirsiniz.

 

[hamza02]

Sayın Orion1 hocam kod yazmayı bilmiyorum ki

 

[hamza02]

Sayın @cengizdemir72 hocam yine hata verdi

 

[Cengiz Demir]

Sayın @cengizdemir72 hocam yine hata verdi

İsterseniz https://s7.dosya.tc/ adresinden dosyanızı yükleyin bir bakayım

 

[Orion1]

Makro kaydeti çalıştırdığınız zaman, kodları otomatik olarak zaten o veriyor.Siz o kodları modüle kopyalacaksınız.
Makro kaydet diye arama yaparsanız,nasıl yapıldığını görebilirsiniz.

 

[hamza02]

https://s7.dosya.tc/ sayfa açmıyor hata veriyor.

 

[Cengiz Demir]

https://s7.dosya.tc/ sayfa açmıyor hata veriyor.

Reklam engelleyici veya virüs programınız engelliyor olabilir.
Nette dosya yükle diye arama yapıp sorunsuz bir site bulup yükleyebilirsiniz.

 

[hamza02]

Barkod_deneme.xlsm

dosyayı indir, full download - Barkod_deneme.xlsm

dosya.org

ilgili çalışmamı yükledim

sayın üstadlar yardımcı olursanız sevinirim

 

[Cengiz Demir]

Merhabalar kodları dosyanıza göre uyarladım. Ama anlamadığım gerip bir sorun oluyor.
Eklediğiniz düğme ve comboboxdan dolayı kodlar çalışmıyor hata veriyor.
Sanki onları da resim olarak algılıyor ve resim olmadıkları için hata veriyor.
Onları silersem kodlar çalışıyor.

 

[hamza02]

Sayın cengizdemir72 hocam peki ne yapabiliriz. Ben dosya üzerinde biraz daha çalıştım. Sizin kod bilgi seviyenizi bilmiyorum ama bu kod olayını iyi bilen bir üstad yardım etse çok iyi olur.