Chèn hình vào cell bằng hàm tự tạo

Liên hệ QC
anhtuan1066

anhtuan1066

Thành viên gạo cội
Tham gia
10/3/07
Bài viết
5,802
Được thích
6,911
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ấp dẫn nhỉ? Vậy mà code lại khá đơn giản:
Mã: 
Function CommPic(Pic As String, Cel As Range) As String
  On Error Resume Next
  Application.Volatile
  Cel.Comment.Delete
  If Cel.Comment Is Nothing Then Cel.AddComment
  Cel.Comment.Text vbLf
  With Cel.Comment.Shape
    .Left = Cel.Left: .Top = Cel.Top: .Visible = True
    .Width = Cel.Width: .Height = Cel.Height
    .Fill.UserPicture Pic
  End With
End Function
Thí nghiệm:
- Mở Excel, chèn code trên vào module, xong lưu file vào 1 thư mục nào đó
- Copy 1 số hình vào cùng thư mục chưa file Excel (file của tôi có 4 hình AT01.jpg, AT02.jpg, AT03.jpg và AT04.jpg)
- Gõ công thức này vào cell B3:
PHP: 
=LEFT(CELL("filename",A1),FIND("[",CELL("filename",A1))-1)
- Từ cell A5 trở xuống, gõ tên các file hình
- Tại cell B5, gõ công thức =$B$3&A5 và kéo fill xuống
- Tại cell C5, gõ công thúc =CommPic(B5,C5) và kéo fill xuống
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
 

File đính kèm

  • TestComPic.rar
    68.2 KB · Đọc: 7,612
Sắp xếp theo thời gian sắp xếp theo bầu chọn
phucymvn đã viết:
Bạn làm xong rồi save as sang excel 2003-2007 gửi cho đối tác OK nhé
Nhấp chuột vào đây để mở rộng...
nếu gởi như vậy mình phải gởi kèm hình ảnh theo mới mở được mà bạn!

mình có 1 vấn đề mong các bạn chỉ giúp! đó là làm sao ko hiện hình ảnh tại ô muốn hiện nhưng chỉ hiện, khi đưa chuột vào mũi tên đỏ thì mới hiện hình ra
Screenshot 2015-03-26 20.49.30.png
xin cám ơn!
 
Lần chỉnh sửa cuối:
Upvote 0
Chao cac ban. chi dùm mình với. sao mình làm tương tự như file có sẵn, chỉ thêm mình và kéo xuống nhưng không thấy ra hình. mong các bạn chỉ dùm. minh xin cám ơn. xem file dinh kèm.
 
Upvote 0
Chao cac ban. chi dùm mình với. sao mình làm tương tự như file có sẵn, chỉ thêm mình và kéo xuống nhưng không thấy ra hình. mong các bạn chỉ dùm. minh xin cám ơn. xem file dinh kèm.
 
Upvote 0
Bạn ơi có cách nào để ảnh không chèn full cell mà sẽ cách mỗi cạnh một khoảng nhất định mình muốn (ví dụ 1milimet) sẽ thẩm mỹ hơn, anh chị nào biết chỉ giúp em với
 
Upvote 0
Xin chào các anh, em có vấn đề này cần được sự giúp đỡ!
Em có các ảnh nằm trong các cell của file excel, các anh chỉ giúp em hàm để select được ảnh ở trong cell khi mình biết vị trí của cell cần select ảnh (ảnh nằmtrong cell đó)
Thanks pro!
 
Upvote 0
Chào anh Tuấn,
Anh có thể giúp em cách đưa hình có sẵn vào trang tính toán (sheet-Draft) theo điều kiện đầu vào ở trang khác (sheet -Cal), như file đính kèm được không ạ. Em giải thích về điều kiện như sau:
1. Sheet cal: số tấm thép (kích thước bản rộng W=2420mm) cần để lắp dựng đạt chiều cao bồn (H16000) là 07 tấm (ô B19), trong đó có 06 tấm nguyên bản rộng W2420 và 01 tấm thiếu W1480.
=>Cần thể hiện minh họa sang Sheet Draft là:
-Copy hình vẽ minh họa tấm nguyên (góc dưới bên phải) chống liên tiếp lên tấm đáy bồn (#1, cố định) theo thứ tự từ tấm #2 đến tấm #6.
-Copy hình minh họa tấm thiếu (nằm trên tấm nguyên) lên vị trí tấm thứ #7 (trên cùng).
-Copy hình minh họa tấm mái bồn (tank roof) lên trên tấm #7.
2. Nếu Bồn có chiều cao H16940 thì ta có 07 tấm nguyên W2420, khi đó ở Sheet Draft hình minh họa bồn là 07 tấm nguyên kích thước giống nhau, và tank roof trên cùng.

Cảm ơn anh Tuấn nhiều.
 

File đính kèm

  • Tank shell.xlsx
    18.3 KB · Đọc: 23
Upvote 0
Xin chào,
Tôi đang rất cần cách chèn hình vào Excel để tập hợp lên kế hoạch tháng. Như bị đắm tàu mà với được phao, gặp ngay vài viết rất hữu ích.
Thật sự tôi không biết gì về VBA cho nên tôi xin nhờ giúp đỡ dựa trên file của anh ndu96081631 với yêu cầu một số thay đổi sau:
1) Insert hình với kích cỡ nhỏ vào 1 sheet chỉ để làm dữ liệu xuất sang sheet khác
2) Xuất sang sheet khác với sắp xếp hình ảnh cứ 4 hình 1 trang có tên file phía dưới hình.
Chân thành cám ơn.
 

File đính kèm

  • ClipArtEvent_03.xls
    68.5 KB · Đọc: 31
Upvote 0
hôm trước em tải file này của anh về và làm được, nay cần dùng đến mở ra không hiểu sao không tài nào làm nổi nữa, giúp em với!
 
Upvote 0
anhtuan1066 đã viết:
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ấp dẫn nhỉ? Vậy mà code lại khá đơn giản:
Mã: 
Function CommPic(Pic As String, Cel As Range) As String
  On Error Resume Next
  Application.Volatile
  Cel.Comment.Delete
  If Cel.Comment Is Nothing Then Cel.AddComment
  Cel.Comment.Text vbLf
  With Cel.Comment.Shape
    .Left = Cel.Left: .Top = Cel.Top: .Visible = True
    .Width = Cel.Width: .Height = Cel.Height
    .Fill.UserPicture Pic
  End With
End Function
Thí nghiệm:
- Mở Excel, chèn code trên vào module, xong lưu file vào 1 thư mục nào đó
- Copy 1 số hình vào cùng thư mục chưa file Excel (file của tôi có 4 hình AT01.jpg, AT02.jpg, AT03.jpg và AT04.jpg)
- Gõ công thức này vào cell B3:
PHP: 
=LEFT(CELL("filename",A1),FIND("[",CELL("filename",A1))-1)
- Từ cell A5 trở xuống, gõ tên các file hình
- Tại cell B5, gõ công thức =$B$3&A5 và kéo fill xuống
- Tại cell C5, gõ công thúc =CommPic(B5,C5) và kéo fill xuống
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
Nhấp chuột vào đây để mở rộng...
Xin hỏi các bạn, khi ta sử dụng hàm để chèn ảnh vào comment ,khí có ảnh thì vô tư rồi . Nhưng khi trường hợp có tên, nhưng không có ảnh thì nó chỉ cho khung comment trống . Vậy bổ xung code thế nào để nó tự xóa các comment không có ảnh ?
 
Lần chỉnh sửa cuối:
Upvote 0
Ngoai Thanh đã viết:
Xin hỏi các bạn, khi ta sử dụng hàm để chèn ảnh vào comment ,khí có ảnh thì vô tư rồi . Nhưng khi trường hợp có tên, nhưng không có ảnh thì nó chỉ cho khung comment trống . Vậy bổ xung code thế nào để nó tự xóa các comment không có ảnh ?
Nhấp chuột vào đây để mở rộng...

Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:
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:
- Như ý anh: 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
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:
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:
- Như ý anh: 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
Nhấp chuột vào đây để mở rộng...
Chiều nhà em đi vắng , chưa hồi âm được . Cám ơn thày !
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:
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
[COLOR=#0000cd]Private[/COLOR] 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")
    [COLOR=#0000cd].Open "HEAD", URL, False: .send
    URLExists = .Status = 200[/COLOR]
  End With
End Function
Nhấp chuột vào đây để mở rộng...
xin thầy giải thích giúp em tại sao phải dùng Private ở function URLExists, và 2 dòng code em tô màu xanh có ý nghĩa gì ạ, và những phương thức đó tham khảo ở đâu, cám ơn thầy
 
Upvote 0
ndu96081631 đã viết:
Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:
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:
- Như ý anh: 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
Nhấp chuột vào đây để mở rộng...

qua thời gian xử dụng em thấy có vài điều thế này, mong thầy xem xét, nếu được thì update cho bản sau he thầy.
thêm mắm muối thế nào để tự động nhận luôn đuôi mở rộng của tấm hình thầy
ví dụ tấm hình 1 tên 1.jpg
tấm hình 2 tên 2.png
hàm sẽ tự động tìm tại đường dẫn đó file tên như vậy và có đuôi mở rộng thỏa thì hiện tấm ảnh đó lên
và thầy có thể bổ xung thêm cho hàm nó mặc định đường dẫn là chung với file excel hiện hành (nếu file có sẵn) luôn được không thầy, nếu là file excel mới tạo (trường hợp hàm trên ở trong add ins) thì đường dẫn mặc đinh là C:\Users\Public\Pictures\
em xin ví dụ nếu là file có sẵn đường dẫn E:\ (code trên là addins) thì tại:
ô A1 là 1
ô A2 là D:\Anh\1
tương ứng ô B1, B2 sẽ là =commpic(RC[-1])
thì tại ô B1 sẽ xuất tấm hình tại đường dẫn E:\1.* (* sẽ là đuôi mở rộng, nếu có tấm hình nào tên là 1 - giả sử có 2 file 1.jpg 1.png thì ưu tiên 1.jpg trước)
tại ô B2 thì sẽ là tấm ảnh 1.* tại đường dẫn đó (* tương tự như trên)-cái này thì hàm trên làm được rồi
còn nếu là file mới tạo chưa lưu thì tại ô B1 sẽ lấy đường dẫn C:\Users\........\Picture\ file ảnh là 1.* (* tương tự như trên)
nếu em có diễn giải hơi loằng ngoằng thì thầy thông cảm bỏ quá cho em
thầy có thể cho nó tự update luôn hay không, chứ mỗi lần thay đổi lại nhấn F9
--------------------------
em xem lại thì thấy "ActiveWorkbook.Path" vậy 1 vấn đề đã giải quyết. còn vụ đuôi mở rộng
--------------------------
hên là đọc code thầy viết còn hiểu
ngồi 1 tí là ra
Mã: 
  If Left(PicPath, 7) = "http://" Then
    bChk = URLExists(PicPath)
  Else
  
[COLOR=#ff0000]Tam = PicPath[/COLOR]
[COLOR=#ff0000]  Dim FormatPic[/COLOR]
[COLOR=#ff0000]  FormatPic = Array(".JPG", ".JPE", ".GIF", ".PNG", ".BMP")[/COLOR]
[COLOR=#ff0000]  For i = 0 To UBound(FormatPic)[/COLOR]
[COLOR=#ff0000]    bChk = fso.FileExists(PicPath)[/COLOR]
[COLOR=#ff0000]    If bChk = False Then[/COLOR]
[COLOR=#ff0000]      PicPath = ThisWorkbook.Path & "\" & Tam & FormatPic(i)[/COLOR]
[COLOR=#ff0000]      bChk = fso.FileExists(PicPath)[/COLOR]
[COLOR=#ff0000]      If bChk Then GoTo Nex[/COLOR]
[COLOR=#ff0000]    End If[/COLOR]
[COLOR=#ff0000]    Next i

[/COLOR][COLOR=#ff0000]If bChk = False Then[/COLOR]
[COLOR=#ff0000]  For i = 0 To UBound(FormatPic)[/COLOR]
[COLOR=#ff0000]    bChk = fso.FileExists(PicPath)[/COLOR]
[COLOR=#ff0000]    If bChk = False Then[/COLOR]
[COLOR=#ff0000]        PicPath = "C:\Users\" & Environ("Username") & "\Pictures\" & Tam & FormatPic(i)[/COLOR]
[COLOR=#ff0000]      bChk = fso.FileExists(PicPath)[/COLOR]
[COLOR=#ff0000]      If bChk Then GoTo Nex[/COLOR]
[COLOR=#ff0000]    End If[/COLOR]
[COLOR=#ff0000]    Next i[/COLOR]
[COLOR=#ff0000]End If[/COLOR]


[COLOR=#ff0000]Nex:[/COLOR]


  End If
  If bChk Then
vấn đề định dạng ảnh và đường dẫn C:\Users\........\Picture\ đã được giải quyết
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:
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:
- Như ý anh: 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
Nhấp chuột vào đây để mở rộng...

Hay quá. Cuối cùng mong muốn bao lâu của em cũng có lời giải. Cho em hỏi thêm là khai báo đường dẫn ảnh ở đâu vậy? Và tại sao em không thêm đối số thì ảnh không chèn vào? Em dùng office 2015??

Thêm một điều này nữa không biết có đến thầy ndu không. Sau khi em chạy lệnh gọi ảnh. Em xóa hết hàm. save lại đuôi xlsm. Cho em hỏi có code nào thêm vào để nếu mình thay đổi độ rộng cell thì comment ảnh nó tự thay đổi theo không?
 
Lần chỉnh sửa cuối:
Upvote 0
Chào anh ndu96081631
Hiện tại, đối với danh sách ngắn, em thường insert hết hình bằng hàm theo chủ đề này. Sau đó, muốn gửi ra ngoài thì em copy từng file ảnh (copy as picture) sau đó delete và cuối cùng là pastespecial as picture (jpeg) thì không cần phải gửi kèm folder hình. Vậy anh có cách nào chèn code vào theo ý tưởng này đc không?
cảm ơn
 
Upvote 0
dauxom đã viết:
Chào anh ndu96081631
Hiện tại, đối với danh sách ngắn, em thường insert hết hình bằng hàm theo chủ đề này. Sau đó, muốn gửi ra ngoài thì em copy từng file ảnh (copy as picture) sau đó delete và cuối cùng là pastespecial as picture (jpeg) thì không cần phải gửi kèm folder hình. Vậy anh có cách nào chèn code vào theo ý tưởng này đc không?
cảm ơn
Nhấp chuột vào đây để mở rộng...

Em cũng đang vướng mắc vấn đề giống thế, bac ndu đâu giúp anh em với ... hay anh em khác nào có thể giúp thì giúp, cảm ơn nhiều
 
Upvote 0
Các bạn cho mình hỏi thêm
Mình có 1 file đã chèn ảnh
Bây giờ mình làm công thức để chuyển hình ảnh từ file đó lên một file khác theo điều kiện
 

File đính kèm

  • Defect list_contruct.xlsx
    364.8 KB · Đọc: 84
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
3
Đọc
112
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
6
Đọc
190
kimtanmap
kimtanmap
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
8
Đọc
97
Hoàng Tuấn 868
H
PhanTuHuong
Bàn về môn thể thao bóng bàn nào!
    • Thích
    • Yêu thích
    • Cười
2
Trả lời
34
Đọc
2K
PhanTuHuong
PhanTuHuong
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
11
Đọc
304
SA_DQ
SA_DQ
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
4
Đọc
161
VetMini
V
ongke0711
  • Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
11 12 13
Trả lời
257
Đọc
25K
Pham Ha 233
Pham Ha 233
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
2
Đọc
120
cherry0187
C
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
4
Đọc
125
Ny Ny 2024
N
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
17
Đọc
327
phutdm
P
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
251
Đọc
13K
ongke0711
ongke0711
N
Định mức nguyên vật liệu
Trả lời
1
Đọc
166
yeudoi
yeudoi
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
1
Đọc
308
PhanTuHuong
PhanTuHuong
B
Định dạng condition formatting, đếm hỗn hợp dữ liệu merge và không merge
Trả lời
17
Đọc
203
batista911
B
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
30
Đọc
717
huuthang_bd
huuthang_bd
H
Tính và sắp xếp theo thư tự tăng dần có điều kiệu (có dữ liệu trùng nhau)
Trả lời
1
Đọc
41
bebo021999
B
V
  • Question
Lấy dữ liệu lãi suất từ website Sbv.gov.vn bằng Power Query
Trả lời
1
Đọc
523
Minhhanhsgu
M
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
149
Đọc
95K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
5
Đọc
153
batista911
B
T
Tối ưu hóa hàm lấy dữ liệu từ bảng Tổng sang bảng chi tiết
Trả lời
7
Đọc
248
Hoàng Tuấn 868
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom