Herkese iyi forumlar;
Hücrelerde bulunan görsellerin hücrenin ortasına hizalanmasını istiyorum bunun için bir makro var elimde ancak bu makro hücrenin sol üstüne sabitliyor.
Bu atacağım makro benim işime yarıyor tek sorun hücrenin sol üstüne sabitlemesi bunu ortaya sabitleyecek şekilde revize etmem gerekiyor yardımcı olur musunuz?
Teşekkürler şimdiden.
Public Sub Fit_All_Selected_Pictures()
Dim pic As Picture
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
Select Case TypeName(Selection)
Case "DrawingObjects"
For Each pic In Selection
PicWtoHRatio = pic.Width / pic.Height
CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With pic
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With pic
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With pic
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Next
Case "Picture"
Set pic = Selection
PicWtoHRatio = pic.Width / pic.Height
CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With pic
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With pic
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With pic
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Case Else
MsgBox "Select 1 or multiple pictures before running this macro."
End Select
End Sub
Hücrelerde bulunan görsellerin hücrenin ortasına hizalanmasını istiyorum bunun için bir makro var elimde ancak bu makro hücrenin sol üstüne sabitliyor.
Bu atacağım makro benim işime yarıyor tek sorun hücrenin sol üstüne sabitlemesi bunu ortaya sabitleyecek şekilde revize etmem gerekiyor yardımcı olur musunuz?
Teşekkürler şimdiden.
Public Sub Fit_All_Selected_Pictures()
Dim pic As Picture
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
Select Case TypeName(Selection)
Case "DrawingObjects"
For Each pic In Selection
PicWtoHRatio = pic.Width / pic.Height
CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With pic
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With pic
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With pic
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Next
Case "Picture"
Set pic = Selection
PicWtoHRatio = pic.Width / pic.Height
CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With pic
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With pic
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With pic
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Case Else
MsgBox "Select 1 or multiple pictures before running this macro."
End Select
End Sub