ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[wexulans]

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.

[EfeM]

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

[wexulans]

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.