Đưa ảnh hiện vào khung (TextBox) bằng VBA

2 Responses

1. hands says:

   23/12/2022 at 11:31 am

   Hướng dẫn em cách đổi tên rectangle với ạ. có phải câu lệch này dùng đổi tên luôn không hả anh?

   With Sheet1.Shapes("PicFrame").Fill
   Em đã test thì thấy code anh load ảnh nhanh hơn file cũ.

   Bạn vẽ rectangle. Đánh dấu vào Rectangle này. Nhìn vào cái hộp Name Box, nó đang có cái tên mặc định gì đó ví dụ như Rectangle 2. Bạn bôi đen dòng chữ này và gõ tên mới (ví dụ PicFrame) rồi gõ Enter là xong.

   Hộp Name Box ở sát phía trên ô A1. (Góc trên trái màn hình).
   Ý tưởng của bác rất hay, như cách các trang tải các trang web. Khi mở file Excel sẽ ra lệnh down các ảnh về thư mục tạm đồng thời –> đổi tên. Tuy nhiên có vấn đề như sau:
   1. Khi mở file (Auto_Open) lệnh download ảnh sẽ thực thi, nó sẽ download tất cả các ảnh (giả sử chưa có sẵn ảnh trong thư mục tạm) điều này sẽ khiến thời gian mở file sẽ lâu (thậm chí rất lâu) –> Gây tâm lý khó chịu cho người dùng file.
   2. Em rất tán thành phương án của bác, nhưng code thế nào thì em pótay.com

   Tốc độ ra sao cứ thử sẽ biết hen:
   1> Code trong Module

   Function DownloadFile(ByVal URL As String, ByVal FileToSave As String) As String
     Dim oXlmHttp As Object, fso As Object
     Dim tmpPath As String
     On Error Resume Next
     Set fso = CreateObject("Scripting.FileSystemObject")
     tmpPath = fso.BuildPath(Environ("TEMP"), FileToSave)
     If Not fso.FileExists(tmpPath) Then
       Set oXlmHttp = CreateObject("Microsoft.XMLHTTP")
       oXlmHttp.Open "GET", URL, False
       oXlmHttp.Send
       URL = oXlmHttp.ResponseBody
       If oXlmHttp.Status = 200 Then
         With CreateObject("ADODB.Stream")
           .Open: .Type = 1
           .Write oXlmHttp.ResponseBody
           .SaveToFile tmpPath
           .Close
         End With
       End If
     End If
     DownloadFile = tmpPath
   End Function
   Sub Auto_Open()
     Dim aSrc, Ret As String, lR As Long
     On Error Resume Next
     aSrc = Sheets("Data").Range("All").Value
     For lR = 1 To UBound(aSrc, 1)
       Ret = DownloadFile(aSrc(lR, 28), aSrc(lR, 1))
     Next
   End Sub

   2> Code sự kiện Change

   Private Sub Worksheet_Change(ByVal Target As Range)
     Dim sPic As String, sURL As String
     On Error Resume Next
     If Target.Address = "$E$8" Then
       sURL = Target.Parent.Range("K4").Value
       With Sheet1.Shapes("PicFrame").Fill
         .Solid: .ForeColor.SchemeColor = 12
         If Len(Trim(sURL)) Then
           sPic = DownloadFile(sURL, Target.Value)
           If Len(sPic) Then .UserPicture sPic
         End If
       End With
     End If
   End Sub

   ————–
   Thử nghiệm:
   – Mở file và chờ trong giây lát. Đến khi hoàn tất, thực hiện code Change bằng cách thay đổi Validation tai E8 —> Cảm nhận tốc độ
   – Đóng file lại và mở lần nữa để kiểm tra
   Chắc chắn từ lần mở file thứ 2 trở đi sẽ không phải chờ đợi gì cả

   Anh ơi đổi tên rectangle như thế nào ạh.

   Gì vậy?
   Xem video clip này nhé:

   DVr20QW_xRI

   Đổi tên bình thường mà

   Cảm ơn anh. Em xin bổ xung thêm là khi đánh xong tên mới kết thúc phải là nhấn "enter" mới đỏi tên được. khi trước em đánh xong tên em kích chuột vào luôn bảng tính hay cho nào đó nên tên không đổi được. Thank!

   Joined27 Jul 2013Messages390Reaction score179Points368Location[URL='www.giaiphapexcel.com/diendan/misc/location-info?location=V%C4%A9nhY%C3%AAn_VP']VĩnhYên_VP

   • [URL='www.giaiphapexcel.com/diendan/threads/%C4%90%C6%B0a-%E1%BA%A3nh-hi%E1%BB%87n-v%C3%A0o-khung-textbox-b%E1%BA%B1ng-vba.84107/post-524766']14 Aug 2013
   • [URL='www.giaiphapexcel.com/diendan/posts/524766/bookmark']Add bookmark
   • [URL='www.giaiphapexcel.com/diendan/threads/%C4%90%C6%B0a-%E1%BA%A3nh-hi%E1%BB%87n-v%C3%A0o-khung-textbox-b%E1%BA%B1ng-vba.84107/post-524766']#16

   Gì vậy?
   Xem video clip này nhé:
   Đổi tên bình thường mà

   Anh ơi em vẫn đang tìm hiểu cái bài này. Anh chỉ em cách làm tại cái cell E8 với ạ. Làm sao để tạo được cái list đó hả anh?
   Anh oi em đã tim trên diễn đàn và tìm được bài anh hướng dẫn trước đó. Nhưng bài hướng dẫn đó lại là combo box (activax control). Em có thử làm như hướng dẫn về cái combo box (activax control) nhưng khi lấy listfillrange tham chieu sang sheet khác thì không biết làm " em thay trên thẻ properties của combo. anh hướng dẫn em với ạh

   Cái đó gọi là Validation bạn à!
   Bạn tự tìm trong Excel (Tab DataData Validation) hoặc tìm trên GPE —> Có đầy

   Chào anh ndu96081631
   Cũng như yêu cầu trên nhưng code để chèn ảnh đã có ở máy tính vào textbox đó như thế nào ạ?

   Em mượn code anh Ndu:
   Với bài trên mà lấy ảnh ở máy bạn thì chố màu đỏ tùy biến theo đường dẫn của file ảnh của bạn

   Private Sub Worksheet_Change(ByVal Target As Range)
     Dim strPic
     On Error Resume Next
     If Target.Address = "$E$8" Then
       strPic = [COLOR=#ff0000]Target.Parent.Range("K4").Value[/COLOR][B][COLOR=#000080] ' có thể tùy biến theo chỗ này[/COLOR][/B]
       With Sheet1.Shapes("PicFrame").Fill
         If strPic <> 0 Then
           .UserPicture [COLOR=#ff0000]CStr(strPic)[/COLOR][B][COLOR=#000080] 'hoặc chỗ này[/COLOR][/B]
         Else
           .Solid: .ForeColor.SchemeColor = 12
         End If
       End With
     End If
   End Sub

   hơn nữa cấu hởi của bạn là đưa ảnh vào "textbox" là đưa danh sách hay cái gì vây???

   http://www.giaiphapexcel.com/diendan/threads/%C4%90%C6%B0a-%E1%BA%A3nh-hi%E1%BB%87n-v%C3%A0o-khung-textbox-b%E1%BA%B1ng-vba.84107/post-524486

   Reply
2. hands says:

   23/12/2022 at 11:36 am

   Em nhờ các anh/ chị giúp cách chèn ảnh vào file Excel. E có dùng code VBA nhưng do không hiểu về Code nên không thực hiện được.
   E gửi file lên đây nhờ anh/ chị chỉ giúp.
   File Ảnh em có file name là số ID của mỗi nhân viên. Khi nhập số ID vào ô Gen thì ảnh tự link vào ô ảnh của file ạ.
   Anh cho em hỏi đoạn lệnh này. =CommPic(B5,C5) . "chỉ hiện thị ảnh trong ô C5 ".Do ảnh của em nằm trong nhiều hàng của Excel. từ hàng ngang C5 -> C8 , hàng dọc từ C5 -> F5 . Trong khoảng đó e đang "Merge & Center " thì em phải sửa lại như thế nào để ảnh hiện thị trên cả các ô đó.
   e cảm ơn anh.

   C5

   D5

   E5

   F5

   C6

   C7

   C8

   e làm mà ảnh vẫn chỉ hiện thị trong 1 cell. anh không có hiện lên nhiều cell ạ.
   em cảm ơn anh!
   Em cảm ơn anh/ chị !

   Đọc chú thích trong code

   1. Với code dưới thì ảnh được nhập vĩnh viễn vào sheet. Khi mang tập tin sang máy khác thì không phải mang ảnh đi theo.
   Với code

   .Fill.UserPicture Pic

   thì khi xóa ảnh trên đĩa hoặc sang máy khác không có ảnh đó thì trên sheet sẽ rỗng. Cho tới cuối đời vẫn phải giữ ảnh trên đĩa. Nếu nhu cầu của bạn đúng là thế thì ngừng đọc tại đây và không dùng code. Vì code nhập ảnh vào sheet vĩnh viễn. Sau đó bạn có thể xóa ảnh trên đĩa hoặc mang sang máy khác.

   2. Bạn có nhiều lựa chọn: nhập vào vùng 1 ô hoặc nhiều ô, nhập vừa khít với vùng, nhập Center trong vùng và nhập ảnh thực.

   3. Thêm 1 Module (Atl+F11 -> Insert -> Module) và dán code dưới vào

   Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                   Optional original As Boolean = False, Optional center As Boolean = False)
   '    Target: vung nhap anh. Co the la nhieu cell
   '    Neu Target = Nothing thi Target = ActiveCell
   '    Neu original = True thi nhap anh kich thuoc thuc.
   '    Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
   '    nguoc lai thi se vua khit vung Target
   Dim w As Double, h As Double, shp As Shape, fso As Object
       If Target Is Nothing Then Set Target = ActiveCell
       On Error Resume Next
       Target.Parent.Shapes("r" & Target.Row & "c" & Target.Column).Delete
       On Error GoTo 0
   
   Set fso = CreateObject("Scripting.FileSystemObject")
   
   If fso.FileExists(PicFilename) Then
           Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
           If Not shp Is Nothing Then
               With shp
                   If original Then
                       .ScaleWidth 1, msoTrue
                       .ScaleHeight 1, msoTrue
                   ElseIf center Then
                       .ScaleWidth 1, msoTrue
                       .ScaleHeight 1, msoTrue
                       w = Target.Width
                       h = w * .Height / .Width
                       If h > Target.Height Then
                           h = Target.Height
                           w = h * .Width / .Height
                       End If
                       .left = Target.left + (Target.Width - w) / 2
                       .top = Target.top + (Target.Height - h) / 2
                       .Width = w
                       .Height = h
                   Else
                       .Width = Target.Width
                       .Height = Target.Height
                   End If
                   shp.Name = "r" & Target.Row & "c" & Target.Column
                   shp.Placement = xlMoveAndSize
               End With
           End If
       End If
   
   Set fso = Nothing
   End Sub

   Center trong vùng C5:F8

   InsertPicture "c:anh1.jpg", worksheets("Sheet1").Range("C5:F8"), FALSE, TRUE

   Vừa khít vùng C5:F8

   InsertPicture "c:anh1.jpg", worksheets("Sheet1").Range("C5:F8"), FALSE, FALSE
   
   hoặc
   
   InsertPicture "c:anh1.jpg", worksheets("Sheet1").Range("C5:F8")

   http://www.giaiphapexcel.com/diendan/threads/%C4%90%C6%B0a-%E1%BA%A3nh-hi%E1%BB%87n-v%C3%A0o-khung-textbox-b%E1%BA%B1ng-vba.84107/post-863151

   Reply