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,905
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,595
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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
3 4 5
Trả lời
84
Đọc
2K
ptm0412
ptm0412
Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
26
Đọc
657
VetMini
V
P
  • Question
Xin code gán mở theo tài khoản/profie đăng nhập bằng gmail sẵn trên trình duyệt
Trả lời
4
Đọc
197
phantu93
P
V
công thức của nó là gì ạ. mong mọi người giúp
Trả lời
1
Đọc
75
CHAOQUAY
C
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
13
Đọc
304
ongke0711
ongke0711
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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