Làm thế nào để lấy thông tin Dimensions ứng với từng picture (2 người xem)

[ginkgo36]

Chào cả nhà,
Em có 1 folder chứa nhiều picture. Nhờ mọi người viết viết 1 function có thể list toàn bộ thông tin của folder đó đó ra file excel với công thông tin như: Name, Date_Modified, Type, Size, Dimensions --> cái này quan trọng ạ ....

Xin cám ơn mọi người.

 

[ndu96081631]

Chào cả nhà,
Em có 1 folder chứa nhiều picture. Nhờ mọi người viết viết 1 function có thể list toàn bộ thông tin của folder đó đó ra file excel với công thông tin như: Name, Date_Modified, Type, Size, Dimensions --> cái này quan trọng ạ ....

Xin cám ơn mọi người.

Bài này cũng... hay hay
Mình cũng có một giải pháp nhưng.. chờ mọi người làm xem thế nào cái (để học hỏi)

 

[ginkgo36]

Sub get_dimesion()
    Dim strFile As String
    Dim stdPic As StdPicture
    Dim lngWidth As Long
    Dim lngHeight As Long
    Dim strPath As String
    Dim lngRow As Long
    Range("A:D").ClearContents
    
    strPath = "Z:\Images\McKesson_Full_Images"
    
    strFile = Dir$(strPath & "\*.*")


    lngRow = Range("A1048576").End(xlUp).Row
    Cells(1, "A").Value = "FileName"
    Cells(1, "B").Value = "Height"
    Cells(1, "C").Value = "Width"


    Do While Len(strFile)


        If UCase$(Right$(strFile, 4)) = ".JPG" Or _
           UCase$(Right$(strFile, 4)) = ".BMP" Or _
           UCase$(Right$(strFile, 4)) = ".PNG" Then
            On Error Resume Next
            Set stdPic = LoadPicture(strPath & "\" & strFile)
            'MsgBox (strPath & "\" & strFile)
            lngRow = lngRow + 1
            Range("A" & lngRow).Value = strFile
            Range("B" & lngRow).Value = Round(stdPic.Width / 26.4583)
            Range("C" & lngRow).Value = Round(stdPic.Height / 26.4583)
ErrorHandler:
        End If


        strFile = Dir$


    Loop
    Exit Sub
End Sub

Em có đoạn code thế này.
Khi em quét qua toàn bộ file hình ảnh trong folder, thì có 1 số hình mặc dù phần đuôi mở rộng là ".jpg" tuy nhiên, khi em nhấn chuột phải lên tấm hình và chọn Edit with Notepad++ thì thấy định dạng của tấm hình là PNG. (mọi người có thể lấy file hình đính kèm - em đính kèm tấm hình ko được - báo lỗi This PNG image has the incorrect file extension. nên em phải nén lại - chắc đây cũng là nguyên nhân hàm của em chạy tới tấm hình này bị lỗi). Và hàm LoadPicture hình như không hỗ trợ PNG.
Vì vậy em phải check nếu gặp những tấm hình như vậy thì bỏ qua. Mọi người có cách nào để có thể lấy luôn những tấm hình đó không ạ?

Em cám ơn

 

[ndu96081631]

Khi em quét qua toàn bộ file hình ảnh trong folder, thì có 1 số hình mặc dù phần đuôi mở rộng là ".jpg" tuy nhiên, khi em nhấn chuột phải lên tấm hình và chọn Edit with Notepad++ thì thấy định dạng của tấm hình là PNG. (mọi người có thể lấy file hình đính kèm - em đính kèm tấm hình ko được - báo lỗi This PNG image has the incorrect file extension. nên em phải nén lại - chắc đây cũng là nguyên nhân hàm của em chạy tới tấm hình này bị lỗi). Và hàm LoadPicture hình như không hỗ trợ PNG.
Vì vậy em phải check nếu gặp những tấm hình như vậy thì bỏ qua. Mọi người có cách nào để có thể lấy luôn những tấm hình đó không ạ?

Em cám ơn

Tôi thì dùng kiểu khác. Tôi dùng Shell.Application, lấy được tất tần tật các chi tiết từ 1 file cho trước
Code sau:

Function FileDetail(ByVal FilePath As String, ByVal index As Long)
  On Error Resume Next
  Dim fldName As String, fleName As String
  With CreateObject("Scripting.FileSystemObject")
    fldName = .GetFile(FilePath).ParentFolder.Path
    fleName = .GetFile(FilePath).Name
  End With
  With CreateObject("Shell.Application")
    With .Namespace("" & fldName & "")
      FileDetail = .Getdetailsof(.ParseName("" & fleName & ""), index)
    End With
  End With
End Function
Sub PicDetailsList()
  Dim vFolder, arrFiles, aIndex
  Dim rngFind As Range
  Dim lR As Long, lC As Long, n As Long, lCountFiles As Long, index As Long
  Dim tmp1 As Date, tmp2 As Date, t As Double
  Dim sFile As String
  On Error Resume Next
  [COLOR=#ff0000]aIndex = Array(177, 0, 3, 182, 1, 31)[/COLOR]
  With CreateObject("Shell.Application")
    vFolder = .BrowseForFolder(0, "", 1).Self.Path
  End With
  If TypeName(vFolder) = "String" Then
    t = Timer
    arrFiles = FilesFoldersList(CStr(vFolder), True, "*.*", False)
    If IsArray(arrFiles) Then
      lCountFiles = UBound(arrFiles) + 1
      ReDim aRes(1 To lCountFiles + 1, 1 To 6)
      For n = 1 To lCountFiles
        sFile = CStr(arrFiles(n - 1))
        If UCase$(Right$(sFile, 4)) = ".JPG" Or _
          UCase$(Right$(sFile, 4)) = ".BMP" Or _
          UCase$(Right$(sFile, 4)) = ".PNG" Then
          lR = lR + 1
          aRes(lR, 1) = FileDetail(sFile, aIndex(0))
          aRes(lR, 2) = FileDetail(sFile, aIndex(1))
          tmp1 = DateValue(FileDetail(sFile, aIndex(2)))
          tmp2 = TimeValue(FileDetail(sFile, aIndex(2)))
          aRes(lR, 3) = tmp1 + tmp2
          aRes(lR, 4) = FileDetail(sFile, aIndex(3))
          aRes(lR, 5) = FileDetail(sFile, aIndex(4))
          aRes(lR, 6) = FileDetail(sFile, aIndex(5))
        End If
      Next
      If lR > 0 Then
        With Sheets("List")
          .Range("A2:F60000").Clear
          .Range("A2").Resize(lR, 6).Value = aRes
          .Columns("A:F").AutoFit
        End With
        MsgBox "Done!", , Timer - t
      End If
    End If
  End If
End Sub

Trong file có dùng hàm FilesFoldersList (đã đăng nhiều lần trên diễn đàn rồi)
Lưu ý: Dòng màu đỏ có mấy con số 177, 0, 3, 182, 1, 31, muốn biết nó là gì, sang sheet Remark xem nhé
----------------------
(chưa hiểu bạn lấy mấy chi tiết này để ứng dụng vào việc gì?)

 

[Quang_Hải]

Tham gia cho vui. Muốn dùng code này phải vào VBE, Tools, Reference và chọn MicroSoft SelfControl And Automation.
Chú ý là file này bỏ chung vào thư mục có chứa hình. Nếu thư mục không có hình lỗi ráng chịu.
Muốn chọn thư mục thì phải chỉnh code chút xíu.

Sub GetFiles()
   Dim fso As Object, ObjFile As Object, Res(1 To 1000, 1 To 5), k, FileType
   Set fso = CreateObject("Scripting.FileSystemObject")
   With fso.GetFolder(ThisWorkbook.Path)
      For Each ObjFile In .Files
         FileType = fso.GetExtensionName(ObjFile)
         If FileType = "jpg" Or FileType = "png" Or FileType = "bmp" Then
            k = k + 1
            Res(k, 1) = ObjFile
            Res(k, 2) = fso.GetFile(ObjFile).DateLastModified
            Res(k, 3) = fso.GetExtensionName(ObjFile)
            Res(k, 4) = fso.GetFile(ObjFile).Size
            Res(k, 5) = GetImageDimension(ThisWorkbook.Path, ObjFile.Name)
         End If
      Next
   End With
   [A1].Resize(k, 5) = Res
End Sub
Function GetImageDimension(Path, FileName)
With CreateObject("Shell.Application")
   With .Namespace(Path)
      With .ParseName(FileName)
         GetImageDimension = .ExtendedProperty("Dimensions")
      End With
   End With
End With
End Function

 

[ndu96081631]

Khi em quét qua toàn bộ file hình ảnh trong folder, thì có 1 số hình mặc dù phần đuôi mở rộng là ".jpg" tuy nhiên, khi em nhấn chuột phải lên tấm hình và chọn Edit with Notepad++ thì thấy định dạng của tấm hình là PNG. (mọi người có thể lấy file hình đính kèm - em đính kèm tấm hình ko được - báo lỗi This PNG image has the incorrect file extension. nên em phải nén lại - chắc đây cũng là nguyên nhân hàm của em chạy tới tấm hình này bị lỗi). Và hàm LoadPicture hình như không hỗ trợ PNG.
Vì vậy em phải check nếu gặp những tấm hình như vậy thì bỏ qua. Mọi người có cách nào để có thể lấy luôn những tấm hình đó không ạ?

Em cám ơn

Nhân có thắc mắc ở bài 3: Đuôi file ta nhìn thấy là JPG nhưng thực chất nó là file PNG
Vậy xin đố các bạn: Làm sao phát hiện được sự khác biệt điều này? (đương nhiên là dùng code để phát hiện)
Điều chúng ta cần ở đây là: File hình bị người ta sửa thành đuôi gì cũng mặc, code vẫn phải phát hiện được chính xác đuôi gốc
Ẹc... Ẹc...

 

[dhn46]

Nhân có thắc mắc ở bài 3: Đuôi file ta nhìn thấy là JPG nhưng thực chất nó là file PNG
Vậy xin đố các bạn: Làm sao phát hiện được sự khác biệt điều này? (đương nhiên là dùng code để phát hiện)
Điều chúng ta cần ở đây là: File hình bị người ta sửa thành đuôi gì cũng mặc, code vẫn phải phát hiện được chính xác đuôi gốc
Ẹc... Ẹc...

Em có ý này không biết có được không?

Sub Test()
    Dim sFile As String, sTxt As String
    sFile = "Duong dan anh"
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso.OpenTextFile(sFile, 1)
        sTxt = .ReadAll
        .Close
    End With
    If Left(sTxt, 4) = "‰PNG" Then
        MsgBox "*.PNG file"
    Else
        MsgBox "*.JPG file"
    End If
End Sub

 

[ndu96081631]

Em có ý này không biết có được không?

Sub Test()
    Dim sFile As String, sTxt As String
    sFile = "Duong dan anh"
    Set fso = CreateObject("Scripting.FileSystemObject")
    With fso.OpenTextFile(sFile, 1)
        sTxt = .ReadAll
        .Close
    End With
    If Left(sTxt, 4) = "‰PNG" Then
        MsgBox "*.PNG file"
    Else
        MsgBox "*.JPG file"
    End If
End Sub

Nếu đuôi file không phải là "PNG" thì đâu thể kết luận nó là "JPG" được nhỉ? (hình ảnh thì có nhiều loại mà)
Ở trên mình có nói:

Điều chúng ta cần ở đây là: File hình bị người ta sửa thành đuôi gì cũng mặc, code vẫn phải phát hiện được chính xác đuôi gốc
.

Code này còn phải sửa nhiều mới hoàn chỉnh được, tuy nhiên đó cũng là ý tưởng hay
(Vẫn còn cách khác nữa: Cực ngắn. Ẹc... Ẹc...)