[Yardım]  Makro ile resim eklemede birleştirilmiş hücreleri görmemesi

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Cevap: Cevap: Makro ile resim eklemede birleştirilmiş hücrel

İleti#21)  wexulans » 08 Oca 2021 22:42

EfeM yazdı:Rica ederim, sene sonu yoğunluktan hemen yazamadım. Ama istersen aşağıdaki kod da Rng.Width - Rng.Height değerleri ile oynayarak hizalayabilirsin.

.Shapes.AddPicture sPicture, msoFalse, msoCTrue, Rng.Left + 2, Rng.Top + 2, Rng.Width - 4, Rng.Height - 4

Kolay gelsin.

Mustafa Hocam, left, top width height değerleri ile oynayınca resim hücre içinde sağa sola kayıyor. Ama daima en boy oranı değişiyor. ben resmim karede olsa yuvarlakda olsa o hücre içine otursun istiyorum tabiki yine kenarlarda +2 + 2 -4 -4 boşlukların bulunması da iyi olacak.
Selection.ShapeRange.LockAspectRatio = msoFalse şu şekilde bir kod eklemem lazım sanırım ama bizim dosyamızda bunu nereye eklemem lazım bilemiyorum. Yardımcı olurmusunuz? rica etsem tekrardan.
Kullanıcı avatarı
wexulans
Yeni Başlamış
 
Kayıt: 25 Eyl 2016 01:17
Meslek: biyolog
Yaş: 31
İleti: 14
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: balıkesir

Cevap: Makro ile resim eklemede birleştirilmiş hücreleri gör

İleti#22)  EfeM » 10 Oca 2021 23:43

Selam,

Anca bakabildim, son hali;


Option Explicit


Sub resimEkle()

Dim sPicture As String, Cs As Worksheet, Rng As Range, Rng2 As Range, z%
Dim resim As Shape

Dim diziSayfalar() As String
diziSayfalar = Split("Sayfa1,Sayfa2,Sayfa3", ",")

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.png; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub
For z = 0 To UBound(diziSayfalar)
For Each Cs In ThisWorkbook.Sheets

With Cs

If .Name = diziSayfalar(z) Then
For Each resim In Cs.Shapes ' önceden varsa silelim.
If resim.Type = msoPicture Then resim.Delete
Next resim
Select Case .Name
Case "Sayfa1"
Set Rng = .Range("d2:i15")
Case "Sayfa2"
Set Rng = .Range("b10:e15")
Case "Sayfa3"
Set Rng = .Range("b10:e15")
Set Rng2 = .Range("g10:k15")
Rng2.Merge
.Shapes.AddPicture sPicture, msoFalse, msoCTrue, Rng2.Left + 2, Rng2.Top + 2, Rng2.Width - 4, Rng2.Height - 4
Set resim = Cs.Shapes(ActiveSheet.Shapes.Count)
Call HucreIcineHizala(resim, Rng2)
Case Else
MsgBox "Resim eklemek için Adres değeri belirtilmemiş"
Set Rng = Nothing
Exit For
End Select
.Activate
Rng.Merge
.Shapes.AddPicture sPicture, msoFalse, msoCTrue, Rng.Left + 2, Rng.Top + 2, Rng.Width - 4, Rng.Height - 4
Set resim = Cs.Shapes(ActiveSheet.Shapes.Count)
Call HucreIcineHizala(resim, Rng)
Exit For
End If
End With
Next
Next z
End Sub

Sub HucreIcineHizala(img As Shape, RngHdf As Range)
With img
.LockAspectRatio = msoTrue
.Height = RngHdf.Height - 30
.Top = RngHdf.Top + (RngHdf.Height / 2) - (.Height / 2)
.Left = RngHdf.Left + (RngHdf.Width / 2) - (.Width / 2)
End With
End Sub
Kullanıcı avatarı
EfeM
Yeni Başlamış
 
Adı Soyadı:Mustafa GUC
Kayıt: 23 Kas 2009 17:29
Konum: İzmir
Meslek: Bilsisayar Programcısı
Yaş: 42
İleti: 45
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İZMİR

Cevap: Cevap: Makro ile resim eklemede birleştirilmiş hücrel

İleti#23)  wexulans » 12 Oca 2021 14:59

EfeM yazdı:Selam,

Anca bakabildim, son hali;


Option Explicit


Sub resimEkle()

Dim sPicture As String, Cs As Worksheet, Rng As Range, Rng2 As Range, z%
Dim resim As Shape

Dim diziSayfalar() As String
diziSayfalar = Split("Sayfa1,Sayfa2,Sayfa3", ",")

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.png; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub
For z = 0 To UBound(diziSayfalar)
For Each Cs In ThisWorkbook.Sheets

With Cs

If .Name = diziSayfalar(z) Then
For Each resim In Cs.Shapes ' önceden varsa silelim.
If resim.Type = msoPicture Then resim.Delete
Next resim
Select Case .Name
Case "Sayfa1"
Set Rng = .Range("d2:i15")
Case "Sayfa2"
Set Rng = .Range("b10:e15")
Case "Sayfa3"
Set Rng = .Range("b10:e15")
Set Rng2 = .Range("g10:k15")
Rng2.Merge
.Shapes.AddPicture sPicture, msoFalse, msoCTrue, Rng2.Left + 2, Rng2.Top + 2, Rng2.Width - 4, Rng2.Height - 4
Set resim = Cs.Shapes(ActiveSheet.Shapes.Count)
Call HucreIcineHizala(resim, Rng2)
Case Else
MsgBox "Resim eklemek için Adres değeri belirtilmemiş"
Set Rng = Nothing
Exit For
End Select
.Activate
Rng.Merge
.Shapes.AddPicture sPicture, msoFalse, msoCTrue, Rng.Left + 2, Rng.Top + 2, Rng.Width - 4, Rng.Height - 4
Set resim = Cs.Shapes(ActiveSheet.Shapes.Count)
Call HucreIcineHizala(resim, Rng)
Exit For
End If
End With
Next
Next z
End Sub

Sub HucreIcineHizala(img As Shape, RngHdf As Range)
With img
.LockAspectRatio = msoTrue
.Height = RngHdf.Height - 30
.Top = RngHdf.Top + (RngHdf.Height / 2) - (.Height / 2)
.Left = RngHdf.Left + (RngHdf.Width / 2) - (.Width / 2)
End With
End Sub



Hocam Elinize kolunuza sağlık ama hala eklediğim resmi en den boydan değiştiriyor. Ben bu belirttiğim hücrelere logo eklettiğimde logo yu bozarak eklemekte maalesef. Yinede çok ama çok teşekkür ederim hakkınızı helal edin. Biraz kod ları kurcalayarak deneyeceğim artık.
Kullanıcı avatarı
wexulans
Yeni Başlamış
 
Kayıt: 25 Eyl 2016 01:17
Meslek: biyolog
Yaş: 31
İleti: 14
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: balıkesir

Önceki

Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Google Adsense [Bot] ve 7 misafir

Bumerang - Yazarkafe