Làm thế nào chèn hình "vừa khít" 1 cell ?

[phanminhphuong]

Chào các bạn!

Mình có đoạn code chèn hình vào cell như sau

Sub Insert_Pictures()

Dim beginR As Long, endR As Long, i As Long
Dim Pic As String

Application.ScreenUpdating = False

On Error Resume Next

beginR = 2 'Dong 2 la dong bat dau chen hinh
endR = [A65536].End(xlUp).Row

  For i = beginR To endR
    Pic = Cells(i, 1).Value & ".jpg"
    ActiveSheet.Shapes(Pic).Delete
      With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Pic)
        .Name = Pic
        .Left = Cells(i, 3).Left + 1
        .Top = Cells(i, 3).Top + 1
        [COLOR=#ff0000].Width = Cells(i, 3).Width - 2[/COLOR]
        [COLOR=#0000cd].Height = Cells(i, 3).Height - 2[/COLOR]
      End With
  Next
  
Application.ScreenUpdating = True

End Sub

tuy nhiên hình chèn vào Cell vẫn giữ nguyên tỉ lệ (chiều rộng/ dài) của hình đó. Mình muốn hình được fit/ chèn vừa khít hay nói cách khác khi chèn hình thì kéo giãn hình ra cho đến gần sát viền của Cell (Kéo giãn hình ra không có vấn đề gì đối với mình cả).

Ở đoạn code trên khi chèn hình vào luôn giữ nguyên tỷ lệ gốc của hình.
Các bạn xem giúp yêu cầu trong file đính kèm

 

[ndu96081631]

tuy nhiên hình chèn vào Cell vẫn giữ nguyên tỉ lệ (chiều rông/ dài) của hình đó. Mình muốn hình được fit/ chèn vừa khít hay nói cách khác khi chèn keo giãn hình ra cho đến gần sát viền của Cell (Kéo giãn hình ra không có vấn đề gì đối với mình cả)

Ở đoạn code khi chèn hình vào luôn giữ nguyên tỷ lệ gốc của hình.
Các bạn xem giúp yêu cầu trong file đính kèm

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

Sub Insert_Pictures()
  Dim beginR As Long, endR As Long, i As Long
  Dim Pic As String
  Application.ScreenUpdating = False
  On Error Resume Next
  beginR = 2
  endR = [A65536].End(xlUp).Row
  For i = beginR To endR
    Pic = Cells(i, 1).Value & ".jpg"
    ActiveSheet.Shapes(Pic).Delete
    With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Pic)
      .Name = Pic
      [COLOR=#ff0000][B].ShapeRange.LockAspectRatio = msoFalse[/B][/COLOR]
      .Left = Cells(i, 3).Left
      .Top = Cells(i, 3).Top
      .Width = Cells(i, 3).Width
      .Height = Cells(i, 3).Height
    End With
  Next
  Application.ScreenUpdating = True
End Sub

Chổ màu đỏ là chổ thêm vào
-----------------------------
Thêm 1 cách nữa:
- Viết luôn 1 hàm để dùng lâu dài

Function InsertPic(ByVal PicPath As String, ByVal Target As Range) As Shape
  Dim shp As Shape
  On Error Resume Next
  With Target
    .Parent.Shapes(Target.Address).Delete
    Set shp = .Parent.Shapes.AddPicture(PicPath, True, True, .Left, .Top, .Width, .Height)
  End With
  If Not shp Is Nothing Then
    shp.Name = Target.Address
    shp.LockAspectRatio = msoFalse
    Set InsertPic = shp
  End If
End Function

Và áp dụng hàm cho file của bạn

Sub Main()
  Dim beginR As Long, endR As Long, i As Long
  Dim Pic As String
  Dim rCel As Range
  Application.ScreenUpdating = False
  For Each rCel In Range([A2], [A65536].End(xlUp))
    Pic = rCel.Value & ".jpg"
    InsertPic ThisWorkbook.Path & "\" & Pic, rCel.Offset(, 2)
  Next
  Application.ScreenUpdating = True
End Sub

Lưu ý: Nên đặt tên Picture là địa chỉ cell, vì đó là tên duy nhất không trùng. Nếu đặt tên cho hình là tên file, chắc chắn sẽ có lúc bị trùng

 

[tueyennhi]

Anh ơi với code .ShapeRange.LockAspectRatio = msoFalse thì ảnh đã tự động khít cell chiều ngang, nhưng chiều dài vì kích thước không giống nhau (112x160, 120x160, 110x160...) nên ảnh nó tự nhảy lên các cell khác, anh có giải pháp nào cho vấn đề này không ạ? Cảm ơn anh nhiều!

 

[ndu96081631]

Anh ơi với code .ShapeRange.LockAspectRatio = msoFalse thì ảnh đã tự động khít cell chiều ngang, nhưng chiều dài vì kích thước không giống nhau (112x160, 120x160, 110x160...) nên ảnh nó tự nhảy lên các cell khác, anh có giải pháp nào cho vấn đề này không ạ? Cảm ơn anh nhiều!

Làm gì có vụ này ta?
Có dòng lệnh .ShapeRange.LockAspectRatio = msoFalse vào thì ảnh sẽ được điều chỉnh theo ý của người dùng, muốn vừa khích chiều nào là do ta tự thiết lập

 

[tueyennhi]

Làm gì có vụ này ta?
Có dòng lệnh .ShapeRange.LockAspectRatio = msoFalse vào thì ảnh sẽ được điều chỉnh theo ý của người dùng, muốn vừa khích chiều nào là do ta tự thiết lập

Đây anh ơi, mặc dù chưa hoàn hảo hẳn nhưng hôm nay anh chị forrum đã giúp em rất nhiều, em mới vào công ty, các anh chị cũng chẳng có giải pháp nào ngoài nhập thủ công ảnh (gần 3000 người ) mà từ 1h30 nhận lệnh đến 5h phải xong . Cảm ơn các anh một lần nữa, yêu mọi người nhiều :x

 

[dhn46]

Đây anh ơi, mặc dù chưa hoàn hảo hẳn nhưng hôm nay anh chị forrum đã giúp em rất nhiều, em mới vào công ty, các anh chị cũng chẳng có giải pháp nào ngoài nhập thủ công ảnh (gần 3000 người ) mà từ 1h30 nhận lệnh đến 5h phải xong . Cảm ơn các anh một lần nữa, yêu mọi người nhiều :x

Tôi không tin lắm vào khả năng chèn cùng một lúc 3.000 cái ảnh vào 1 file.
Tôi nghĩ tuỳ vào mục đích để mà làm chứ cùng 1 lúc mà chèn số lượng lớn ảnh như thế này thì CÓ KHẢ THI?

Cái Form của bạn là form quản lý tình trạng nhân sự liệu có cần thiết phải truy xuất cùng 1 lúc nhiều như thế? Thường thì trong các báo cáo hay làm thẻ chỉ cần số lượng ảnh nhất định mới làm mà thôi.

Đôi điều suy nghĩ.

 

[ndu96081631]

Đây anh ơi, mặc dù chưa hoàn hảo hẳn

Bạn có thể đưa file lên để tôi xem code mà bạn đang dùng được không?