excel'e Makro yardımı ile resim yükleme

umutgurkan · 24 Nisan 2017

Merhaba sevgili Excel kullanıcıları,

Resimli proforma fatura ya da fiyat teklifi taslağı hazırlamam gerekiyor. Aşağıdaki kodları Excel de Visual basic yardımı ile yazdım. Resimler geliyor fakat benim sorunum şu, Gelen resimlerim belirlediğim hücrelerin boyutunun dışına çıkıyor. bunun sebebi belki resimlerin pikselinin çok olması ve ya bazı fotoğraflar düşeyde çekildiğinden mi bilemedim. Belirlediğim hücrenin içerisine ölçekli bir şekilde fotoğrafları oturtabileceğim kodlar arıyorum. hatta o hücreden biraz küçük olsun ve mousse ile değişiklik yapma şansım da olsun istiyorum. Sevgili editörler yardımcı olursanız çok memnun olurum. 2 gündür uğraşıyorum ama netice alamadım.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C:C]) 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 = 20 To 41

resimyolu = ActiveWorkbook.Path & "\" & Range("c" & satır) & ".jpg"
'resmi oluştur
Set resim = ActiveSheet.Pictures.Insert(resimyolu)
'resmi boyutlandır
With Range("d" & satır)
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With
Next satır
çıkış:
End Sub

PLİNT · 24 Nisan 2017

Merhaba
Hücre ile aynı boyutta olması için kodlarınızın aşağıdaki ilgili bölümüne mavi eki yaparak,
sağdan ve alttan yüzde 10 kadar küçük olması içinde kırmızı bölümleri ekleyerek deneyiniz.

Kod:

[SIZE="2"]
'.....
'....kodlar
'....
'resmi boyutlandır
With Range("d" & satır)
[COLOR="Blue"]resim.ShapeRange.LockAspectRatio = msoFalse[/COLOR]
resim.Top = .Top
resim.Left = .Left
resim.Height =.Height[COLOR="Red"]  - .Height * 0.1[/COLOR]
resim.Width = .Width[COLOR="Red"] - .Width * 0.1[/COLOR]
End With
Next satır
çıkış:
End Sub [/SIZE]

umutgurkan · 24 Nisan 2017

selam plint;

Çok teşekkürler işe yarıyor gerçekten, son olarak başını ağartıyorum ama mouse ile ufak müdaheleler edebileyim ve bir sonraki değişiklikde bu değişmesin. Bunu nasıl yapabilirim yardımcı olabilir misin.
Birde soldan ve üstten %10 daha nasıl küçültebilirim? tekrar teşekkürler

PLİNT · 24 Nisan 2017

Merhaba
Aşağıdaki değişiklerle hücreye ortalayabilirsiniz, mouse ile isteğinizi anlamadım ama resmin üzerine tıklayıp oluşan köşelerden mause ile çekerek büyütüp küçültebilirsiniz.
Kodların içinde "10" u yüzde olarak ayarlarsınız

Kod:

[SIZE="2"]
'......
'....kodlarınız
'.........

'resmi boyutlandır
[COLOR="Red"]Dim m As Double[/COLOR]
With Range("d" & satır)
resim.ShapeRange.LockAspectRatio = msoFalse
resim.Top = .Top
resim.Left = .Left
[COLOR="Red"]m = (1 / 100) [COLOR="RoyalBlue"]* 10[/COLOR]
resim.Height = .Height - .Height * m
resim.Width = .Width - .Width * m

m = m / 2
resim.ShapeRange.IncrementTop .Height * m
resim.ShapeRange.IncrementLeft .Width * m[/COLOR]
End With
Next satır
çıkış:
End Sub [/SIZE]

umutgurkan · 24 Nisan 2017

sevgili plint,

Emeğin için çok teşekkürler o kadar mükemmel oldu ki tam istediğim gibi,
Sağolasın çok memnun oldum bu forumda senin gibi bir arkadaşın olduğun artık buradan başka bir yere de bakmam.

PLİNT · 24 Nisan 2017

umutgurkan' Alıntı:
sevgili plint,

Emeğin için çok teşekkürler

Rica ederim, kolay gelsin.

umutgurkan · 25 Nisan 2017

selam plint tekrar,

ya son bir sorunum daha var. senin de başını epey ağarttık kusura bakma lütfen buna da yardımcı olursan gerçekten çok memnun kalacağım.
Dosyayayı buradan değilde ActiveWorkbook.Path & "\Yeni fiyat teklifi için Resimler\" şuradan almasını istiyorum C:\Users\dogru\Google Drive\TASLAK_\taslaklar\gürkan doğru taslak RESİMLİ\Yeni Fiyat teklifi için Resimler kısmından almasını istiyorum . denedim ama olmadı hata verdi.

İkincisi ve son olanı resimi olmayan bir barkodu yazdığım zaman bundan sonra gelen satırlarda da o koda ait resim bulunmasına rağmen resim gelmiyor bunu da çözebilirsen o eşsiz hünerlerinle çok memnun olurum. yardımcı olamazsan da sorun değil zaten fazlası ile yardımcı oldun.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C:C]) 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 = 20 To 41

resimyolu = ActiveWorkbook.Path & "\Yeni fiyat teklifi için Resimler\" & Range("c" & satır) & ".jpg"
'resmi oluştur
Set resim = ActiveSheet.Pictures.Insert(resimyolu)
'resmi boyutlandır
Dim m As Double
With Range("d" & satır)
resim.ShapeRange.LockAspectRatio = msoFalse
resim.Top = .Top
resim.Left = .Left
m = (1 / 100) * 20
resim.Height = .Height - .Height * m
resim.Width = .Width - .Width * m

m = m / 2
resim.ShapeRange.IncrementTop .Height * m
resim.ShapeRange.IncrementLeft .Width * m

End With
Next satır
çıkış:
End Sub

PLİNT · 25 Nisan 2017

Merhaba
Aşağıda "yol" tanımında; tırnaklar arasını; resimlerin alınacağı klasör adresini;
adres çubuğundan kopyalayıp yapıştırın ki eksiklik olmasın,
barkodunu yazdığınız resmin formatı "jpg" olmadığı için gelmemiş olabilir, ilgili klasörde resimle aynı isimle başka formatlı dosya olmamak şartı ile aşağı gibi deneyelim.

Kod:

[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C:C]) 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
[COLOR="Red"]Set a = CreateObject("scripting.filesystemobject")[/COLOR]

[SIZE="4"]yol =[/SIZE] "[COLOR="Blue"]C:\Users\dogru\Google Drive\TASLAK_\taslaklar\gürkan doğru taslak RESİMLİ\Yeni Fiyat teklifi için Resimler[/COLOR]\"

For satır = 21 To 41
[COLOR="Red"]resimyolu = yol & "\" & Dir(yol & Range("c" & satır).Value & ".*")[/COLOR]
[COLOR="Red"]If a.FileExists(resimyolu) = True Then[/COLOR]
Set resim = ActiveSheet.Pictures.Insert(resimyolu)
'resmi boyutlandır
Dim m As Double
With Range("d" & satır)
resim.ShapeRange.LockAspectRatio = msoFalse
resim.Top = .Top
resim.Left = .Left
m = (1 / 100) * 20
resim.Height = .Height - .Height * m
resim.Width = .Width - .Width * m
m = m / 2
resim.ShapeRange.IncrementTop .Height * m
resim.ShapeRange.IncrementLeft .Width * m
End With
[COLOR="Red"]End If[/COLOR]
Next satır
çıkış:
End Sub [/SIZE]

umutgurkan · 28 Nisan 2017

selam plint,

çok sağol herşey mükemmel oldu gerçekten bize çağ atlattın varol sağol.

)

snn38 · 5 Mayıs 2017

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E2]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error GoTo çıkış

Set Alan = Range("G10")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing

Dim Resimyolu As Variant
Dim resim As Object
Resimyolu = ActiveWorkbook.Path & "\" & Range("E2") & ".jpg"
Set resim = ActiveSheet.Pictures.Insert(Resimyolu)
With Range("G10")
resim.Top = .Top
resim.Left = .Left
resim.Height = .Height
resim.Width = .Width
End With
Application.ScreenUpdating = True

çıkış:

End Sub

Dim resim As Object kısmında

duplicate declaration in current scope

HATASI ALIYORUM

YARDIMLARINIZI BEKLİYORUM