Bài viết: Chèn hình vào cell bằng hàm tự tạo

Liên hệ QC

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia
5/6/08
Bài viết
30,703
Được thích
53,930
Xưa nay người ta thường chèn hình vào bảng tính bằng 1 thủ tục nào đó (Sub...). Vậy các bạn có nghĩ rằng có thể chèn hình bằng hàm tự tạo không? Tức là ta gõ hàm vào cell, lập tức hình được chèn vào ngay cell ấy!
Ví dụ ta gõ thế này: =CommPic("D:\Pic\Hinh 1.jpg",C5) thì lập tức Hinh 1.jpg được chèn vừa vặn vào cell C5.

Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:


pc-hW08rN1te8uxUpvtqfBrvC4V9HAnX74jdPohoSueOcb0nTnnl4Lee_tb2HGG_7Fv8MLHH9Nq2DTveKU9AMOuPRomNVC8vShuVSz76mtZc5TS5jaLfu28Tc7yC3TmYnE8ave1-YBAZEqWAliX7rnj1-r3DQieM6tzdshDC4Sn6o408d7-TrGGqLH5xlA-Sr2igmDEk2befNo8gA8CdR3rE8aD0-AkBskqh92duE7qB7ZyuojnUTMY62m6cTR8cAPnmDlgFomgQ8c84PemR4S05nXb511sRhYrws4btyDomgh5-GGRwLK1G8lZ1i0l4ZIIvnHoD8cxM5bn49gwSBwV5WK-p3-0zWWP2-Xwizo9c-89wOIjbNkHXq9g0mOpYe3mC-dIcin0Zz19lmndyC_JW0uUBVeYgTV-Tssf5uMZXL49RPBif6brnwi2dTAustXVfalofiSafcp1wr1Kj5s0SEtzcvCccXUe9cYX3JN-8jrzmBuZv-HKzFQ_G6nHsqm2bkslXA-tK8VuSuvIKy4kQktRKN69MMNpf9giYANLc3N-NoY223sCfIgBDrn0AYne1iq4SxQFk5zvNJB1FfYgzdgmDxpPw6v2mufgrStk0Z079gr_u=w988-h681-no


Mã:
Function CommPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
                Optional ByVal ScaleWidth As Single = 1, _
                Optional ByVal ScaleHeight As Single = 1) As String
  Dim mRng As Range, cmt As Comment, fso As Object, bChk As Boolean
  On Error Resume Next
  Application.Volatile
  Set fso = CreateObject("Scripting.FileSystemObject")
  If PicCel Is Nothing Then Set PicCel = Application.ThisCell
  PicCel(1, 1).Comment.Delete
  If Left(PicPath, 7) = "http://" Then
    bChk = URLExists(PicPath)
  Else
    bChk = fso.FileExists(PicPath)
    If bChk = False Then
      PicPath = ThisWorkbook.Path & "\" & PicPath
      bChk = fso.FileExists(PicPath)
    End If
  End If
  If bChk Then
    If PicCel(1, 1).Comment Is Nothing Then PicCel(1, 1).AddComment
    PicCel(1, 1).Comment.Text vbLf
    Set mRng = PicCel(1, 1).MergeArea
    If mRng Is Nothing Then Set mRng = PicCel(1, 1)
    Set cmt = mRng(1, 1).Comment
    cmt.Visible = True
    With cmt.Shape
      .LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Shadow.Visible = msoFalse
      .Line.ForeColor.RGB = PicCel.Interior.Color
      .AutoShapeType = msoShapeRectangle
      .Left = mRng.Left: .Top = mRng.Top
      .Width = mRng.Width: .Height = mRng.Height
      .ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Fill.UserPicture PicPath
    End With
  End If
End Function
Private Function URLExists(ByVal URL As String) As Boolean
  Application.Volatile
  On Error Resume Next
  If Left(UCase(URL), 7) <> "HTTP://" Then URL = "http://" & URL
  With CreateObject("MSXML2.XMLHTTP")
    .Open "HEAD", URL, False: .send
    URLExists = .Status = 200
  End With
End Function

Khả năng của hàm:
- Nếu đường dẫn không tồn tại, sẽ xóa Comment.
- Cho phép chèn hình có trong ổ đĩa máy tính hoặc hình trên Web.
- Tự động thay đổi size hình và dịch chuyển theo cell (khi cell thay đổi kích thước, chỉ cần bấm F9 để cập nhật).
- Cho phép thu nhỏ, phóng to hình tùy ý. Ví dụ =CommPic(A1, , 80%, 80%) có nghĩa là thu nhỏ chiều ngang và chiều dọc 80% so với cell (mặc định là 100%)
Những khả năng mở rộng chỉ là dạng Optional, nếu anh không thích dùng vẫn có thể bỏ qua không cần khai báo. Ví dụ anh chỉ muốn chèn hình vào cell B1, với đương dẫn nằm ở A1, vậy chỉ cần gõ vào B1 thế này là đủ: =CommPic(A1) mà không cần quan tâm những đối số phía sau.

Xem thử hình đã được Add vào có ngoạn mục không?
Hy vọng tạo sự dễ dàng cho các bạn, những ai quan tâm đến việc chèn hình ảnh vào bảng tính.


Một số bài viết có liên quan:
1/ Tặng các bạn file "QUAY SỐ TRÚNG THƯỞNG"
2/ Tặng tiện ích CALENDAR (Excel 2007 trở về sau)
3/ Tặng phần mềm in mã vạch
4/ Làm nhãn vở học sinh trên Excel
5/ Tặng hàm Calculate tính giá trị theo nội dung diễn giải
6/ Dùng Macro 4 để lấy dữ liệu từ 1 file đang đóng
7/ Gọi một Private Sub
8/ Cách chạy macro trong sheet bị protect
9/ Viết hàm VBA như thế nào là tốt
10/ Hàm Sum nhiều tính năng
 

File đính kèm

  • Giaiphapexcel.com_TestComPic.zip
    73.9 KB · Đọc: 31
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote 0
Không làm được, down file về mở cũng không hiện hình ảnh lên
Bạn có thể giải thích hàm : LEFT(CELL("filename",A1),FIND("[",CELL("filename",A1))-1)
Mình xin cảm ơn.
 
Mình làm theo hướng dẫn nhưng không thành công @@
 
Mình làm theo hướng dẫn nhưng không thành công @@
bạn thử cái này xem sao nha. mình đã chỉnh sửa lại cho dễ, khỏi nhớ công thức loằng ngoằng
Mã:
Public Function CommPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
            Optional ByVal ScaleWidth As Single = 1, Optional ByVal ScaleHeight As Single = _
            1) As String


    Dim mRng As Range, cmt As Comment, FSO As Object, bChk As Boolean
    Dim NameOld As String
    Dim FormatPic(), LinkPic()
    Dim j As Byte, i As Byte


    On Error Resume Next
    Application.Volatile


    Set FSO = CreateObject("Scripting.FileSystemObject")


    If PicCel Is Nothing Then Set PicCel = Application.ThisCell


    PicCel(1, 1).Comment.Delete


    If Left$(PicPath, 7) = "http://" Then
        bChk = URLExists(PicPath)
    Else


        On Error GoTo Thoat


        'neu duong dan nhap vao dung thi thuc hien lenh chen anh, nguoc lai thi kiem tra va chinh sua lai duong dan
        If FSO.FileExists(PicPath) Then GoTo Nex


        'khai bao mang duoi dinh dang anh
        FormatPic = Array(".JPG", ".JPEG", ".JPE", ".TIFF", ".GIF", ".PNG", ".BMP")


        'khai bao duong dan 1: file hien tai, 2: picture
        LinkPic = Array(ActiveWorkbook, _
                CreateObject("Shell.Application").Namespace(&H27&).Self)


        'ten duong  dan anh nhap vao
        NameOld = UCase(PicPath)


        For i = 0 To UBound(FormatPic)
            NameOld = Replace(NameOld, FormatPic(i), "")    'xoa dinh dang cu di
        Next i


        For j = 0 To UBound(LinkPic)


            For i = 0 To UBound(FormatPic)
                PicPath = LinkPic(j).Path & "\" & NameOld & FormatPic(i)    'thay the duong dan moi va dinh dang moi


                If FSO.FileExists(PicPath) Then GoTo Nex


            Next i


        Next j


Nex:
    End If


    'neu link  chinh xac thi chen hinh anh
    If FSO.FileExists(PicPath) Then


        If PicCel(1, 1).MergeCells Then


            Set mRng = PicCel(1, 1).MergeArea


            If mRng Is Nothing Then Set mRng = PicCel(1, 1)


        Else


            Set mRng = PicCel


        End If


        With Application.ThisCell


            If .Comment Is Nothing Then .AddComment


            .Comment.text vbLf


            Set cmt = .Comment


            'CommPic = ""
        End With


        'Set cmt = mRng(1, 1).Comment
        cmt.Visible = True
        ActiveSheet.PageSetup.PrintComments = xlPrintInPlace


        With cmt.Shape
            .LockAspectRatio = msoFalse
            .Placement = xlMoveAndSize
            .Shadow.Visible = msoFalse
            .Line.ForeColor.RGB = PicCel.Interior.Color
            .AutoShapeType = msoShapeRectangle
            .Left = mRng.Left
            .Top = mRng.Top
            .Width = mRng.Width
            .Height = mRng.Height
            .ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
            .ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
            .Fill.UserPicture PicPath
            .PrintObject = True
        End With


    Else


        Application.ThisCell.Comment.Delete 'nguoc  lai xoa hinh di


    End If


Thoat:


End Function


Private Function URLExists(ByVal URL As String) As Boolean


    Application.Volatile
    On Error Resume Next


    If Left$(UCase(URL), 7) <> "HTTP://" Then URL = "http://" & URL


    With CreateObject("MSXML2.XMLHTTP")
        .Open "HEAD", URL, False: .sEnd
        URLExists = .Status = 200
    End With


End Function
cách dùng
=CommPic("image",A1:D1)
là hình ảnh có tên "image" sẽ được chèn vào vùng A1:D1
không cần biết đuôi ảnh là gì. chỉ cần tên ảnh thôi. sẽ sai nếu có 2 file tên ảnh giống nhau mà đuôi mở rộng khác nhau nha.
mặc định sẽ lấy theo đường dẫn chung với file excel, nếu không có thì sẽ tìm trong thư mục picture
vẫn có thể cung cấp đường dẫn đầy đủ được
ví dụ
=CommPic("C:\Users\Public\Pictures\Sample Pictures\picture.jpg",A1:D1)
 
cách dùng
=CommPic("image",A1:D1)
là hình ảnh có tên "image" sẽ được chèn vào vùng A1:D1
không cần biết đuôi ảnh là gì. chỉ cần tên ảnh thôi.

Nếu có nhu cầu dò tìm nhiều loại đuôi file thì tôi nghĩ bạn nên viết 1 hàm riêng để làm việc này. Một hàm chỉ nên làm công việc chính của nó, không nên ôm đồm quá nhiều thứ, bởi rất khó quản lý
 
Thầy Ndu cho em hỏi chút có cách nào để biết file ảnh đó có tồn tại hay không ví dụ
=IFERROR(CommPic(A9&".jpg",,100%,100%),"NG").
 
Mấy chục người thì đơn giản nhưng nếu mấy chục nghìn thì cách này không khả quan đâu bạn.
Bạn phải nói rõ ra dựa vào dữ liệu gì để xác định?, dữ liệu thế nào? nằm ở đâu?.
theo như công thức bên trên bạn có ghi
Mã:
[COLOR=#000000]=IFERROR(CommPic(A9&".jpg",,100%,100%),"NG").
thì không bao giờ nó ra được giá trị "NG" đâu. theo mình biết là thế.
bạn nói không rõ vấn đề thì ai mà giúp được.[/COLOR]
 
Ừm thì mình biết là không được nên mới hỏi. Mình viết thế để mọi người hiểu ý của mình muốn gì. Chung quy mình muốn là có thể Filter được xem ô nào không có ảnh để mà biết bổ sung.
 
Ừm thì mình biết là không được nên mới hỏi. Mình viết thế để mọi người hiểu ý của mình muốn gì. Chung quy mình muốn là có thể Filter được xem ô nào không có ảnh để mà biết bổ sung.
thế bạn biết sửa code không
biết thì thêm khúc này vô nha
thêm vào sau đoạn này
Mã:
      .ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Fill.UserPicture PicPath
    End With
End If
[B][COLOR=#ff0000]Thêm vào đây
[/COLOR][/B]End function

hiện chữ "Not Picture" khi không có ảnh
Mã:
If PicCel(1, 1).Comment Is Nothing Then Commpic ="Not Picture" Else Compic = ""
hoặc
hiện PicPath: đường dẫn ảnh khi không có ảnh, tức là A9&".jpg" của bạn đó
Mã:
If PicCel(1, 1).Comment Is Nothing Then Commpic =[COLOR=#000000]PicPath[/COLOR] Else Compic = ""
nếu không được thỉ gửi file kèm ảnh lên tui sửa lại cho
 
Xưa nay người ta thường chèn hình vào bảng tính bằng 1 thủ tục nào đó (Sub...). Vậy các bạn có nghĩ rằng có thể chèn hình bằng hàm tự tạo không? Tức là ta gõ hàm vào cell, lập tức hình được chèn vào ngay cell ấy!
Ví dụ ta gõ thế này: =CommPic("D:\Pic\Hinh 1.jpg",C5) thì lập tức Hinh 1.jpg được chèn vừa vặn vào cell C5.

Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:


pc-hW08rN1te8uxUpvtqfBrvC4V9HAnX74jdPohoSueOcb0nTnnl4Lee_tb2HGG_7Fv8MLHH9Nq2DTveKU9AMOuPRomNVC8vShuVSz76mtZc5TS5jaLfu28Tc7yC3TmYnE8ave1-YBAZEqWAliX7rnj1-r3DQieM6tzdshDC4Sn6o408d7-TrGGqLH5xlA-Sr2igmDEk2befNo8gA8CdR3rE8aD0-AkBskqh92duE7qB7ZyuojnUTMY62m6cTR8cAPnmDlgFomgQ8c84PemR4S05nXb511sRhYrws4btyDomgh5-GGRwLK1G8lZ1i0l4ZIIvnHoD8cxM5bn49gwSBwV5WK-p3-0zWWP2-Xwizo9c-89wOIjbNkHXq9g0mOpYe3mC-dIcin0Zz19lmndyC_JW0uUBVeYgTV-Tssf5uMZXL49RPBif6brnwi2dTAustXVfalofiSafcp1wr1Kj5s0SEtzcvCccXUe9cYX3JN-8jrzmBuZv-HKzFQ_G6nHsqm2bkslXA-tK8VuSuvIKy4kQktRKN69MMNpf9giYANLc3N-NoY223sCfIgBDrn0AYne1iq4SxQFk5zvNJB1FfYgzdgmDxpPw6v2mufgrStk0Z079gr_u=w988-h681-no


Mã:
Function CommPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
                Optional ByVal ScaleWidth As Single = 1, _
                Optional ByVal ScaleHeight As Single = 1) As String
  Dim mRng As Range, cmt As Comment, fso As Object, bChk As Boolean
  On Error Resume Next
  Application.Volatile
  Set fso = CreateObject("Scripting.FileSystemObject")
  If PicCel Is Nothing Then Set PicCel = Application.ThisCell
  PicCel(1, 1).Comment.Delete
  If Left(PicPath, 7) = "http://" Then
    bChk = URLExists(PicPath)
  Else
    bChk = fso.FileExists(PicPath)
    If bChk = False Then
      PicPath = ThisWorkbook.Path & "\" & PicPath
      bChk = fso.FileExists(PicPath)
    End If
  End If
  If bChk Then
    If PicCel(1, 1).Comment Is Nothing Then PicCel(1, 1).AddComment
    PicCel(1, 1).Comment.Text vbLf
    Set mRng = PicCel(1, 1).MergeArea
    If mRng Is Nothing Then Set mRng = PicCel(1, 1)
    Set cmt = mRng(1, 1).Comment
    cmt.Visible = True
    With cmt.Shape
      .LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Shadow.Visible = msoFalse
      .Line.ForeColor.RGB = PicCel.Interior.Color
      .AutoShapeType = msoShapeRectangle
      .Left = mRng.Left: .Top = mRng.Top
      .Width = mRng.Width: .Height = mRng.Height
      .ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Fill.UserPicture PicPath
    End With
  End If
End Function
Private Function URLExists(ByVal URL As String) As Boolean
  Application.Volatile
  On Error Resume Next
  If Left(UCase(URL), 7) <> "HTTP://" Then URL = "http://" & URL
  With CreateObject("MSXML2.XMLHTTP")
    .Open "HEAD", URL, False: .send
    URLExists = .Status = 200
  End With
End Function

Khả năng của hàm:
- Nếu đường dẫn không tồn tại, sẽ xóa Comment.
- Cho phép chèn hình có trong ổ đĩa máy tính hoặc hình trên Web.
- Tự động thay đổi size hình và dịch chuyển theo cell (khi cell thay đổi kích thước, chỉ cần bấm F9 để cập nhật).
- Cho phép thu nhỏ, phóng to hình tùy ý. Ví dụ =CommPic(A1, , 80%, 80%) có nghĩa là thu nhỏ chiều ngang và chiều dọc 80% so với cell (mặc định là 100%)
Những khả năng mở rộng chỉ là dạng Optional, nếu anh không thích dùng vẫn có thể bỏ qua không cần khai báo. Ví dụ anh chỉ muốn chèn hình vào cell B1, với đương dẫn nằm ở A1, vậy chỉ cần gõ vào B1 thế này là đủ: =CommPic(A1) mà không cần quan tâm những đối số phía sau.

Xem thử hình đã được Add vào có ngoạn mục không?
Hy vọng tạo sự dễ dàng cho các bạn, những ai quan tâm đến việc chèn hình ảnh vào bảng tính.


Một số bài viết có liên quan:
1/ Tặng các bạn file "QUAY SỐ TRÚNG THƯỞNG"
2/ Tặng tiện ích CALENDAR (Excel 2007 trở về sau)
3/ Tặng phần mềm in mã vạch
4/ Làm nhãn vở học sinh trên Excel
5/ Tặng hàm Calculate tính giá trị theo nội dung diễn giải
6/ Dùng Macro 4 để lấy dữ liệu từ 1 file đang đóng
7/ Gọi một Private Sub
8/ Cách chạy macro trong sheet bị protect
9/ Viết hàm VBA như thế nào là tốt
10/ Hàm Sum nhiều tính năng
Thầy có thể viết bổ sung thêm mọi định dạng ảnh không ví dụ jpg hay png cũng đều chạy
 
Web KT
Back
Top Bottom