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 đó

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,189
Được thích
52,473
Điểm
11,910
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ỉ?
Chưa hiểu ý bạn là HIỆN như thế nào?
Bài đã được tự động gộp:

Có thầy ạ! em clik vào đó nhưng không thấy tác đông gì ạ?
Thầy xem giúp em ạ!
Bạn phải bấm nút "Get Images" trước thì click mới có tác dụng chứ
 

Kieutri

Thành viên hoạt động
Tham gia ngày
20 Tháng bảy 2018
Bài viết
137
Được thích
16
Điểm
170
Tuổi
35
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ứ
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

vc_đi chơi

Thành viên hoạt động
Tham gia ngày
21 Tháng chín 2019
Bài viết
109
Được thích
24
Điểm
20
Tuổi
29
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ứ
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:

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,189
Được thích
52,473
Điểm
11,910
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 ạ!

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?
 

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,189
Được thích
52,473
Điểm
11,910
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.
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)
 

Kieutri

Thành viên hoạt động
Tham gia ngày
20 Tháng bảy 2018
Bài viết
137
Được thích
16
Điểm
170
Tuổi
35
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)
E cảm ơn anh, anh ơi đoạn code này em code vào Module hay This book vậy anh.
 

xuantocdotb

Thành viên mới
Tham gia ngày
1 Tháng sáu 2016
Bài viết
37
Được thích
8
Điểm
165
Tuổi
31
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
Với file đuôi ".pdf" thì có ứng dung được code trên không thưa thầy?
 

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,189
Được thích
52,473
Điểm
11,910
Với file đuôi ".pdf" thì có ứng dung được code trên không thưa thầy?
Đượ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:

E cảm ơn anh, anh ơi đoạn code này em code vào Module hay This book vậy anh.
Không nói gì nghĩa là cho vào module đó bạn
 

Kieutri

Thành viên hoạt động
Tham gia ngày
20 Tháng bảy 2018
Bài viết
137
Được thích
16
Điểm
170
Tuổi
35
Đượ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
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

xuantocdotb

Thành viên mới
Tham gia ngày
1 Tháng sáu 2016
Bài viết
37
Được thích
8
Điểm
165
Tuổi
31
Đượ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
Em cảm ơn thầy!
 

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,189
Được thích
52,473
Điểm
11,910
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.
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

Kieutri

Thành viên hoạt động
Tham gia ngày
20 Tháng bảy 2018
Bài viết
137
Được thích
16
Điểm
170
Tuổi
35
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
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
Em cảm ơn anh rất nhiều. Tuyệt quá anh ạ.
 

batman1

Thành viên gắn bó
Tham gia ngày
8 Tháng chín 2014
Bài viết
2,504
Được thích
3,787
Điểm
560
Em cảm ơn anh rất nhiều. Tuyệt quá anh ạ.
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.
 

xuantocdotb

Thành viên mới
Tham gia ngày
1 Tháng sáu 2016
Bài viết
37
Được thích
8
Điểm
165
Tuổi
31
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.
Dạ đúng ạ! Anh chỉnh lại giúp em được không ạ?
Cảm ơn anh!
 

Kieutri

Thành viên hoạt động
Tham gia ngày
20 Tháng bảy 2018
Bài viết
137
Được thích
16
Điểm
170
Tuổi
35
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.
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 ạ.
 
Top Bottom