Giúp code chỉnh chiều cao của Shapes (2 người xem)

[congnguyen88]

Tôi có dùng đoạn Code này đùng để chèn ảnh vào 1 ô

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, [B3:B1002]) Is Nothing Then
Dim vFile
vFile = Application.GetOpenFilename("All Pictures, *.bmp;*.jpg;*.jpeg;*.png;*.gif")
If TypeName(vFile) = "String" Then
With ActiveCell
ActiveSheet.Shapes.AddPicture(CStr(vFile), msoFalse, msoTrue, .Left, .Top, .Width, .Height).Placement = xlMoveAndSize
End With
End If
End If
End Sub

Code ở trên khi chèn ảnh vào thì nó nằm trọn vẹn trong 1ô . Bây giờ tôi muốn chiều cao của nó hạ xuống 1 chút ( ScaleHeight 0.83 ) thì phải làm sao

 

[Quang_Hải]

Mình chỉ đoán thôi, bạn thử chỉnh xem được không. Sửa số 20 cho đến khi vừa ý. Nếu cái hình mất cân đối thì chỉnh thêm .Width - 20

..., msoFalse, msoTrue, .Left, .Top, .Width, .Height)

>>> , msoFalse, msoTrue, .Left, .Top + 20 , .Width, .Height - 20)

 

[congnguyen88]

Mình chỉ đoán thôi, bạn thử chỉnh xem được không. Sửa số 20 cho đến khi vừa ý. Nếu cái hình mất cân đối thì chỉnh thêm .Width - 20

..., msoFalse, msoTrue, .Left, .Top, .Width, .Height)

>>> , msoFalse, msoTrue, .Left, .Top + 20 , .Width, .Height - 20)

Ok mình làm được rồi. sẳng đây bạn giúp mình code xóa tất cả các "Picture" ảnh chỉ chừa lại 1 hay nhiều cái "Rectangle " do mình chỉ định
- Nghĩa là sau khi chèn ảnh vào rồi, thay vì Mình Ctrl + G để xóa đi các ảnh đó, bây giờ mình muốn
Click vào nút bấm thì nó sẽ tự động xóa hết tất các "Picture" hiện đang có trên Sheet đó, nhưng phải
chừa lại 1 hay nhiều cái "Rectangle " ( lý do chừa lại tại vì cái "Rectangle " đó dùng để làm các nút bấm )