Lấy tên nội dung của file ảnh vào excel và tự động mở file ảnh khi chọn nội dung đó

Liên hệ QC
Kieutri đã viết:
Thật tuyệt vời quá anh ơi, cảm ơn anh nhiều. Nhưng tìm được tên có cách nào ảnh đó hiện lên luôn không anh nhỉ?
Nhấp chuột vào đây để mở rộng...
Chưa hiểu ý bạn là HIỆN như thế nào?
Bài đã được tự động gộp:

vc_đi chơi đã viết:
Có thầy ạ! em clik vào đó nhưng không thấy tác đông gì ạ?
Thầy xem giúp em ạ!
Nhấp chuột vào đây để mở rộng...
Bạn phải bấm nút "Get Images" trước thì click mới có tác dụng chứ
 
ndu96081631 đã viết:
Chưa hiểu ý bạn là HIỆN như thế nào?
Bài đã được tự động gộp:


Bạn phải bấm nút "Get Images" trước thì click mới có tác dụng chứ
Nhấp chuột vào đây để mở rộng...
Em bấm rồi ạ, hiện nội dung tên của file ảnh, nhưng không hiện lên được "Hình ảnh" ở cột ghi chú ạ. Anh giúp em với anh.
 

File đính kèm

  • Dat.rar
    1.1 MB · Đọc: 4
ndu96081631 đã viết:
Chưa hiểu ý bạn là HIỆN như thế nào?
Bài đã được tự động gộp:


Bạn phải bấm nút "Get Images" trước thì click mới có tác dụng chứ
Nhấp chuột vào đây để mở rộng...
Em bấm nút "Get Images" thì sẽ lấy được tên các file anhsang excel nhưng khi click vào ô nội dung tương ứng trong các ô trong excel thì không có tác động gì, nó giống như những ô excel thông thường không có chứa liên kết thầy ạ!

 
Lần chỉnh sửa cuối:
vc_đi chơi đã viết:
Em bấm nút "Get Images" thì sẽ lấy được tên các file anhsang excel nhưng khi click vào ô nội dung tương ứng trong các ô trong excel thì không có tác động gì, nó giống như những ô excel thông thường không có chứa liên kết thầy ạ!

Nhấp chuột vào đây để mở rộng...
Người ta hướng dẫn là CLICK trong khi bạn lại DOUBLE CLICK, sao mà có tác dụng được?
 
Kieutri đã viết:
Em bấm rồi ạ, hiện nội dung tên của file ảnh, nhưng không hiện lên được "Hình ảnh" ở cột ghi chú ạ. Anh giúp em với anh.
Nhấp chuột vào đây để mở rộng...
Bài toán của bạn khác với yêu cầu của chủ đề này
Theo ý bạn thì code phải sửa lại hơi nhiều:
Mã: 
Sub GetImages()
  Dim oFile As Object
  Dim pic As Picture
  Dim cel As Range
  Dim wks As Worksheet
  Dim sPath As String, sExt As String
  Dim idx As Long
  Const IMG_FILTER As String = "/JPG/GIF/JFIF/PNG/"
  'On Error Resume Next
  Set wks = Worksheets("Trang_t?nh1")
  wks.Range("C5:D1000").Clear
  idx = 4
  sPath = ThisWorkbook.Path
  With CreateObject("Scripting.FileSystemObject")
    For Each oFile In .GetFolder(sPath).Files
      sExt = .GetExtensionName(oFile)
      If InStr(1, IMG_FILTER, "/" & sExt & "/", vbTextCompare) Then
        idx = idx + 1
        wks.Cells(idx, 3) = idx - 4
        wks.Cells(idx, 4) = Left(oFile.Name, Len(oFile.Name) - Len(sExt) - 1)
        wks.Cells(idx, 4).ID = oFile
        Set cel = wks.Cells(idx, 5)
        On Error Resume Next
        wks.Pictures("Pic" & cel.Address).Delete
        On Error GoTo 0
        Set pic = wks.Pictures.Insert(oFile.Path)
        pic.ShapeRange.LockAspectRatio = msoFalse
        pic.Name = "Pic" & cel.Address
        pic.Left = cel.Left: pic.Top = cel.Top
        pic.Width = cel.Width: pic.Height = cel.Height
        pic.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromMiddle
        pic.ShapeRange.ScaleWidth 0.8, msoFalse, msoScaleFromMiddle
      End If
    Next
  End With
End Sub
(thêm phần chèn hình)
 
ndu96081631 đã viết:
Bài toán của bạn khác với yêu cầu của chủ đề này
Theo ý bạn thì code phải sửa lại hơi nhiều:
Mã: 
Sub GetImages()
  Dim oFile As Object
  Dim pic As Picture
  Dim cel As Range
  Dim wks As Worksheet
  Dim sPath As String, sExt As String
  Dim idx As Long
  Const IMG_FILTER As String = "/JPG/GIF/JFIF/PNG/"
  'On Error Resume Next
  Set wks = Worksheets("Trang_t?nh1")
  wks.Range("C5:D1000").Clear
  idx = 4
  sPath = ThisWorkbook.Path
  With CreateObject("Scripting.FileSystemObject")
    For Each oFile In .GetFolder(sPath).Files
      sExt = .GetExtensionName(oFile)
      If InStr(1, IMG_FILTER, "/" & sExt & "/", vbTextCompare) Then
        idx = idx + 1
        wks.Cells(idx, 3) = idx - 4
        wks.Cells(idx, 4) = Left(oFile.Name, Len(oFile.Name) - Len(sExt) - 1)
        wks.Cells(idx, 4).ID = oFile
        Set cel = wks.Cells(idx, 5)
        On Error Resume Next
        wks.Pictures("Pic" & cel.Address).Delete
        On Error GoTo 0
        Set pic = wks.Pictures.Insert(oFile.Path)
        pic.ShapeRange.LockAspectRatio = msoFalse
        pic.Name = "Pic" & cel.Address
        pic.Left = cel.Left: pic.Top = cel.Top
        pic.Width = cel.Width: pic.Height = cel.Height
        pic.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromMiddle
        pic.ShapeRange.ScaleWidth 0.8, msoFalse, msoScaleFromMiddle
      End If
    Next
  End With
End Sub
(thêm phần chèn hình)
Nhấp chuột vào đây để mở rộng...
E cảm ơn anh, anh ơi đoạn code này em code vào Module hay This book vậy anh.
 
ndu96081631 đã viết:
Làm cho bạn luôn đây
1> Code trong module:
Mã: 
Sub GetImages()
  Dim oFile As Object
  Dim sPath As String, sExt As String
  Dim idx As Long
  Const IMG_FILTER As String = "/JPG/GIF/JFIF/PNG/"
  'On Error Resume Next
  Range("C5:D1000").Clear
  idx = 4
  sPath = ThisWorkbook.Path
  With CreateObject("Scripting.FileSystemObject")
    For Each oFile In .GetFolder(sPath).Files
      sExt = .GetExtensionName(oFile)
      If InStr(1, IMG_FILTER, "/" & sExt & "/", vbTextCompare) Then
        idx = idx + 1
        Cells(idx, 3) = idx - 4
        Cells(idx, 4) = Left(oFile.Name, Len(oFile.Name) - Len(sExt) - 1)
        Cells(idx, 4).ID = oFile
      End If
    Next
  End With
End Sub
2> Code trong sự kiện SectionChange
Mã: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim FSO As Object
  Set FSO = CreateObject("Scripting.FileSystemObject")
  'On Error Resume Next
  If Not Intersect(Range("D5:D1000"), Target) Is Nothing Then
    If Target.Count = 1 Then
      If FSO.FileExists(Target.ID) Then Shell "Explorer.exe /Select, " & """" & Target.ID & """", 1
    End If
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Với file đuôi ".pdf" thì có ứng dung được code trên không thưa thầy?
 
xuantocdotb đã viết:
Với file đuôi ".pdf" thì có ứng dung được code trên không thưa thầy?
Nhấp chuột vào đây để mở rộng...
Được nhưng chỉ dừng ở mức lấy tên file vào tạo liên kết thôi nha. Đương nhiên pdf không phải hình nên chẳng thể "hiển thị" được
Bài đã được tự động gộp:

Kieutri đã viết:
E cảm ơn anh, anh ơi đoạn code này em code vào Module hay This book vậy anh.
Nhấp chuột vào đây để mở rộng...
Không nói gì nghĩa là cho vào module đó bạn
 
ndu96081631 đã viết:
Được nhưng chỉ dừng ở mức lấy tên file vào tạo liên kết thôi nha. Đương nhiên pdf không phải hình nên chẳng thể "hiển thị" được
Bài đã được tự động gộp:


Không nói gì nghĩa là cho vào module đó bạn
Nhấp chuột vào đây để mở rộng...
Em có copy đoạn code anh gửi dán vào module mà không được anh ạ. Em đang thao tác sai ở đoạn nào. a sửa giúp em với ạ. Chủ đề này hay quá. Em cảm ơn anh nhiều.
 

File đính kèm

  • Dat.rar
    938.3 KB · Đọc: 6
Kieutri đã viết:
Em có copy đoạn code anh gửi dán vào module mà không được anh ạ. Em đang thao tác sai ở đoạn nào. a sửa giúp em với ạ. Chủ đề này hay quá. Em cảm ơn anh nhiều.
Nhấp chuột vào đây để mở rộng...
Có 2 chỗ sai:
1> Bạn copy vô bị dư dòng "End Sub" (đang có 2 cái End Sub)
2> Tôi sai: Chẳng biết copy paste thế nào mà Set wks = Worksheets("Trang_tính1") lại trở thành Set wks = Worksheets("Trang_t?nh1") <--- Cái "Trang_tính1" chính là tên sheet của bạn đó <--- Sửa lại giúp tôi nhé
3> Cuối cùng thì: Thôi tôi sửa cho bạn luôn đây
 

File đính kèm

  • Quanlyanh.xls
    79 KB · Đọc: 20
ndu96081631 đã viết:
Có 2 chỗ sai:
1> Bạn copy vô bị dư dòng "End Sub" (đang có 2 cái End Sub)
2> Tôi sai: Chẳng biết copy paste thế nào mà Set wks = Worksheets("Trang_tính1") lại trở thành Set wks = Worksheets("Trang_t?nh1") <--- Cái "Trang_tính1" chính là tên sheet của bạn đó <--- Sửa lại giúp tôi nhé
3> Cuối cùng thì: Thôi tôi sửa cho bạn luôn đây
Nhấp chuột vào đây để mở rộng...
ndu96081631 đã viết:
Có 2 chỗ sai:
1> Bạn copy vô bị dư dòng "End Sub" (đang có 2 cái End Sub)
2> Tôi sai: Chẳng biết copy paste thế nào mà Set wks = Worksheets("Trang_tính1") lại trở thành Set wks = Worksheets("Trang_t?nh1") <--- Cái "Trang_tính1" chính là tên sheet của bạn đó <--- Sửa lại giúp tôi nhé
3> Cuối cùng thì: Thôi tôi sửa cho bạn luôn đây
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh rất nhiều. Tuyệt quá anh ạ.
 
Kieutri đã viết:
Em cảm ơn anh rất nhiều. Tuyệt quá anh ạ.
Nhấp chuột vào đây để mở rộng...
Code chưa đủ đâu. Bạn hãy đóng tập tin rồi mở lại. Sau đó chọn vd. D5 thì bạn biết tôi nói gì.

cell.ID chỉ tồn tại cho tới khi đóng tập tin. Khi mở tập tin thì mọi cell.ID đều là mặc định, tức chuỗi rỗng.
 
batman1 đã viết:
Code chưa đủ đâu. Bạn hãy đóng tập tin rồi mở lại. Sau đó chọn vd. D5 thì bạn biết tôi nói gì.

cell.ID chỉ tồn tại cho tới khi đóng tập tin. Khi mở tập tin thì mọi cell.ID đều là mặc định, tức chuỗi rỗng.
Nhấp chuột vào đây để mở rộng...
Dạ đúng ạ! Anh chỉnh lại giúp em được không ạ?
Cảm ơn anh!
 
batman1 đã viết:
Code chưa đủ đâu. Bạn hãy đóng tập tin rồi mở lại. Sau đó chọn vd. D5 thì bạn biết tôi nói gì.

cell.ID chỉ tồn tại cho tới khi đóng tập tin. Khi mở tập tin thì mọi cell.ID đều là mặc định, tức chuỗi rỗng.
Nhấp chuột vào đây để mở rộng...
Em đóng vào, thấy code vẫn chạy bình thường mà anh. File vẫn chạy kể cả khi copy sang 1 folder khác ạ.
 
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

H
Nhờ hướng dẫn chuyển hàng thành cột và dữ liệu theo nhu cầu bằng VBA
Trả lời
1
Đọc
47
DeTong
D
H
  • Question
Code VBA cho kết quả dòng, cột theo điều kiện từ 2 Sheets
Trả lời
2
Đọc
71
SA_DQ
SA_DQ
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
2
Đọc
61
NguyenthiH
NguyenthiH
T
Cần giúp sao chép C1 từ B1
Trả lời
3
Đọc
82
tle2003
T
A
Tìm số nhỏ nhất, số lớn nhất theo ngày
Trả lời
6
Đọc
76
hoangtuaotrang_hp_vn
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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