Nút lệnh tự resize ảnh và cố định ảnh vào ô

[luuhoangkiem]

Khi thao tác trên excel, em thường copy hình trên mạng và bỏ vào excel. Nút lệnh này giúp mình tự resize ảnh theo kích thước của ô và move ảnh lọt vào ô để tránh ảnh chèn lên các đường kẻ.
Nếu ảnh to hơn ô muốn chèn --> tự resize nhỏ lại
Nếu ảnh nhỏ hơn ô muốn chèn --> tự phóng to ảnh ra

Điều kiện:
1. Chọn ảnh, move góc trái trên cùng của ảnh nằm trong ô muốn chứa ảnh
2. Phải chọn ảnh, nếu ko sẽ hiện bảng thông báo.

Em có copy trên mạng một module tên là fitpic
Sau đó vẽ 1 rectangle và assign macro cho rectangle đó là fitpic

Tuy nhiên giờ em muốn chỉnh sửa là mỗi lẫn click rectangle đó thì ảnh sẽ căn giữa ô (ngang dọc giữa hết) thì phải làm như thế nào ạ. Hiện tại nó toàn căn lề trái và top.
Xin các cao thủ trợ giúp với ạ, em gửi cả code và file mẫu kèm theo

Public Sub FitPic()On Error GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Selection
.Width = .TopLeftCell.Width / 1.1
.Height = .Width / PicWtoHRatio
End With
Case Else
With Selection
.Height = .TopLeftCell.RowHeight / 1.1
.Width = .Height * PicWtoHRatio
End With
End Select
With Selection
.Top = .TopLeftCell.Top + 5
.Left = .TopLeftCell.Left + 5
End With
Exit Sub
NOT_SHAPE:
MsgBox "HomeOffice Bot: Chon anh truoc khi click"
End Sub

 

[ndu96081631]

Khi thao tác trên excel, em thường copy hình trên mạng và bỏ vào excel. Nút lệnh này giúp mình tự resize ảnh theo kích thước của ô và move ảnh lọt vào ô để tránh ảnh chèn lên các đường kẻ.
Nếu ảnh to hơn ô muốn chèn --> tự resize nhỏ lại
Nếu ảnh nhỏ hơn ô muốn chèn --> tự phóng to ảnh ra

Điều kiện:
1. Chọn ảnh, move góc trái trên cùng của ảnh nằm trong ô muốn chứa ảnh
2. Phải chọn ảnh, nếu ko sẽ hiện bảng thông báo.

Em có copy trên mạng một module tên là fitpic
Sau đó vẽ 1 rectangle và assign macro cho rectangle đó là fitpic

Tuy nhiên giờ em muốn chỉnh sửa là mỗi lẫn click rectangle đó thì ảnh sẽ căn giữa ô (ngang dọc giữa hết) thì phải làm như thế nào ạ. Hiện tại nó toàn căn lề trái và top.
Xin các cao thủ trợ giúp với ạ, em gửi cả code và file mẫu kèm theo

Public Sub FitPic()On Error GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Selection
.Width = .TopLeftCell.Width / 1.1
.Height = .Width / PicWtoHRatio
End With
Case Else
With Selection
.Height = .TopLeftCell.RowHeight / 1.1
.Width = .Height * PicWtoHRatio
End With
End Select
With Selection
.Top = .TopLeftCell.Top + 5
.Left = .TopLeftCell.Left + 5
End With
Exit Sub
NOT_SHAPE:
MsgBox "HomeOffice Bot: Chon anh truoc khi click"
End Sub

Sửa thành vầy thử xem:

Public Sub FitPic()
  Dim pic As Picture
  If TypeOf Selection Is Picture Then
    Set pic = Selection
    Pic2Cel pic, [COLOR=#ff0000]pic.TopLeftCell[/COLOR], [COLOR=#0000cd]0.8[/COLOR]
  Else
    MsgBox "Chon anh truoc khi click"
  End If
End Sub
Private Sub Pic2Cel(ByVal pic As Picture, ByVal cel As Range, Optional ByVal dScale As Double = 1)
  Dim dist As Double, dWith As Double, dHeight As Double
  dWith = cel.Width * dScale
  dist = (cel.Width - dWith) / 2
  dHeight = cel.Height - 2 * dist
  With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Placement = xlMoveAndSize
    .Left = cel.Left + dist: .Top = cel.Top + dist
    .Width = dWith: .Height = dHeight
  End With
End Sub

Lưu ý:
- Chỗ màu đỏ (pic.TopLeftCell) là cell mà bạn muốn chèn hình. Ở đây tôi cho chèn hình vào cell gần với góc trái phía trên của hình. Nếu muốn chèn vào cell cố định nào đó thì sửa chỗ này (chẳng hạn là Range("A1") )
- Chỗ màu xanh (0.8) là tỉ lệ thu nhỏ (hoặc phóng to). Nếu bạn không ghi gì cả thì nó sẽ chèn vừa khít với cell. Nếu con số này lớn hơn 1 thì hình sẽ tràn ra khỏi cell

 

[luuhoangkiem]

Sửa thành vầy thử xem:

Public Sub FitPic()
  Dim pic As Picture
  If TypeOf Selection Is Picture Then
    Set pic = Selection
    Pic2Cel pic, [COLOR=#ff0000]pic.TopLeftCell[/COLOR], [COLOR=#0000cd]0.8[/COLOR]
  Else
    MsgBox "Chon anh truoc khi click"
  End If
End Sub
Private Sub Pic2Cel(ByVal pic As Picture, ByVal cel As Range, Optional ByVal dScale As Double = 1)
  Dim dist As Double, dWith As Double, dHeight As Double
  dWith = cel.Width * dScale
  dist = (cel.Width - dWith) / 2
  dHeight = cel.Height - 2 * dist
  With pic
    .ShapeRange.LockAspectRatio = msoFalse
    .Placement = xlMoveAndSize
    .Left = cel.Left + dist: .Top = cel.Top + dist
    .Width = dWith: .Height = dHeight
  End With
End Sub

Lưu ý:
- Chỗ màu đỏ (pic.TopLeftCell) là cell mà bạn muốn chèn hình. Ở đây tôi cho chèn hình vào cell gần với góc trái phía trên của hình. Nếu muốn chèn vào cell cố định nào đó thì sửa chỗ này (chẳng hạn là Range("A1") )
- Chỗ màu xanh (0.8) là tỉ lệ thu nhỏ (hoặc phóng to). Nếu bạn không ghi gì cả thì nó sẽ chèn vừa khít với cell. Nếu con số này lớn hơn 1 thì hình sẽ tràn ra khỏi cell

Dạ em cám ơn thầy nhiều lắm ạ. Em đã test cách của thầy và thành công, nhưng khi scale lại không theo tỉ lệ ạ. Ảnh nó bị dẹt ra chứ ko scale cùng lúc dài và rộng được ạ. Sửa chỗ nào để nó tự lấy tỉ lệ dài/rộng ban đầu rồi nếu scale 1 chiều dài thì chiều rộng sẽ scale theo tỉ lệ đã tính trước đó (hoặc ngược lại) vậy thầy. Như đoạn code cũ thì nó lấy tỉ lệ từ đầu nên ảnh dù to hay nhỏ khi scale lại vào ô đều không bị biến dạng 1 chiều.

Rất mong thầy chỉ giáo em thêm ạ. Em đang tập tành VBA ^_^. Em gửi kèm hình bên dưới cho thầy xem ạ:

 

[ndu96081631]

Dạ em cám ơn thầy nhiều lắm ạ. Em đã test cách của thầy và thành công, nhưng khi scale lại không theo tỉ lệ ạ. Ảnh nó bị dẹt ra chứ ko scale cùng lúc dài và rộng được ạ. Sửa chỗ nào để nó tự lấy tỉ lệ dài/rộng ban đầu rồi nếu scale 1 chiều dài thì chiều rộng sẽ scale theo tỉ lệ đã tính trước đó (hoặc ngược lại) vậy thầy. Như đoạn code cũ thì nó lấy tỉ lệ từ đầu nên ảnh dù to hay nhỏ khi scale lại vào ô đều không bị biến dạng 1 chiều.

Rất mong thầy chỉ giáo em thêm ạ. Em đang tập tành VBA ^_^. Em gửi kèm hình bên dưới cho thầy xem ạ:

View attachment 168056

Tôi chưa hiểu?
Bạn muốn thế nào cứ đưa file lên đây nhé

 

[luuhoangkiem]

Tôi chưa hiểu?
Bạn muốn thế nào cứ đưa file lên đây nhé

Dạ Thầy ơi em gửi file excel mẫu nè Thầy.
Ý em là code của thầy giúp em cố định ảnh vào giữa cell, nhưng ảnh sẽ bị dẹt nếu chiều rộng cell đó hẹp, nó sẽ bị dẹt ảnh. Thầy xem file excel em đính kèm theo trả lời này giúp em nha thầy.

 

[alibaba2209]

code ngon rồi thầy ơi! em cảm ơn thầy nhiều

 

[DanVanPhoto]

Code rất hay ạ. Nhưng mọi người cho em hỏi. Nếu em muốn cho ảnh vừa với một cell được gộp mergeCells thì phải làm ntn ạ. Code trên chỉ vừa với row và column. Em rất cảm ơn ạ

 

[Hoàng Tuấn 868]

thì phải làm ntn ạ.

Thì cứ làm ntn thôi.

 

[DanVanPhoto]

Thì cứ làm ntn thôi.

code trên làm cho hình ảnh vừa với duy nhất một ô. mà em lại gộp các ô lại với nhau. muốn cho hình vừa với ô mới gộp mà chạy lệnh nó chỉ vừa với kích thước ban đầu khi chưa gộp ô ạ.