Cần giúp, xuất hình ảnh từ file excel vơi tên file theo list có sẵn

[hunglao]

EM có một danh sách tên và hình ảnh khá dài, 3000 dòng, muốn xuất hình ảnh ở cột K với tên file nằm ở cột B
Nêu xuất thủ công dễ sai sot và mất khá nhiều thời gian. Em cũng yếu về lập trình nên nhở anh/c giúp giùm

Em xin cảm ơn

 

[siwtom]

Đúng như bác siwtom đã nhận xét.
Cốt lõi là codes của anh NDU chỉ xuất ra file Bitmap. Việc đổi đuôi là ".JPG" hay là gì gì đó là do mình tự gạt mình thôi, bản chất VBA chỉ xuất ra định dạng ảnh chuẩn Windows là Bitmap. Thế nên dung lượng chúng bằng nhau là vậy. (Nếu 2 ảnh như nhau về độ phân giải, kích thước... thì ảnh JPG sẽ có kích thước nhỏ hơn BMP)

Cái này tôi đã viết một lần nhưng nhìn bài trong chủ đề này thì hóa ra không ai tin. Tin hay không là quyền mỗi người nhưng ngạc nhiên chút là dễ kiểm tra mà lại không kiểm tra.

Mình chỉ cần xuất ra ảnh là đạt mục đích rồi. Nếu muốn thành đuôi gì thì có quá nhiều tool làm việc này chuyên nghiệp, nhanh, gọn, lẹ

Có điều không phải ai cũng cài những phần mềm có phí. Nhiều người không cài vì nhu cầu không cần tới như thế, người khác đơn giản vì không muốn hoặc không dám vi phạm bản quyền. Mua thì vô lý vì chả cần tới đó, vả lại không sống từ việc làm đồ họa chuyên nghiệp thì chả lý gì lại đầu tư vào phần mềm phí cao. Dùng Paint cho nhu cầu thường ngày là được. Nhưng nếu 1 lần trong đời có vài trăm (vài nghìn) ảnh như bạn hunglao thì có lẽ tốt hơn nếu có thể ghi luôn thành JPG. Ghi vài trăm BMP rồi dùng Paint để convert thành JPG có lẽ là khổ nhục kế. Thậm chí nếu dùng những phần mềm miễn phí khác thì thao tác cho vài trăm (vài nghìn) BMP --> JPG bao giờ cũng là thêm việc.

Nếu làm trong Delphi thì Delphi có module jpeg. Có thể nạp BMP và ghi thành JPG. Nếu dùng VBA thì có thể tìm trên mạng module cho JPG.

 

[tedaynui]

Cái này tôi đã viết một lần nhưng nhìn bài trong chủ đề này thì hóa ra không ai tin. Tin hay không là quyền mỗi người nhưng ngạc nhiên chút là dễ kiểm tra mà lại không kiểm tra.

- Không phải "không ai tin" nhận xét của bác mà là không phải ai cũng hiểu rõ cấu trúc file ảnh như bác được. Chỉ cần thấy gắn đuôi JPG là nghĩ nó chính là JPG đó mà. Thật ra, chẳng cần kiểm tra cũng biết; vì đâu thể nào trong chuỗi filename gắn đuôi gì thì VBA sẽ tự biết xuất ra đúng định file đó chứ (không lẽ gắn .TXT thì nó xuất ra kiểu text sao???); Một là codes khác hoặc giả sử code đó nhưng phải có tham số theo sau nó mới phân biệt được chứ,...

- Xuất ra BMP xử lý thành JPG vô cùng đơn giản (cho dù số lượng lớn). Nhưng nếu xuất ra được JPG thì tuyệt vời. Vì mình nghĩ đơn giản là file JPG có dung lượng nhỏ hơn BMP (cùng kích thước, phân giải,..) nên việc ghi file sẽ nhanh hơn.

- Còn việc Convert file ảnh thì chỉ cần Google là bao la, từ tính phí tới miễn phí.

Với mình thì code của anh NDU là giải quyết được công việc như mong muốn, phần còn lại tự xử thôi (không khó mấy nếu khó đưa lên GPE tiếp, hi hi).

 

[hunglao]

Các bác ơi, mới hôm nay chạy lại thì gặp lỗi này

"Sub Main() Dim pic As Shape, rngShp As Range, FSO As Object, IPicDisp As IPictureDisp
Dim fileName As String
On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each pic In sheet4.Shapes
If pic.Type = msoPicture Then
Set rngShp = ShapeRange(pic)
fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
If Not FSO.FileExists(fileName) Then
Set IPicDisp = PictureFromObject(pic, True)
SavePicture IPicDisp, fileName
End If
End If
Next
End Sub
"

Nếu VBA như thế thì nó sẽ quét tất cả các hình trên toàn bộ sheet. Em cần nó chỉ quét trên hình nào nó nằm ở cột K thôi

Em thay dòng bôi đậm phía trên thành " For Each pic In Sheet4.columns(11).Shapes" mà chạy không thấy gì cả

 

[ndu96081631]

Nếu VBA như thế thì nó sẽ quét tất cả các hình trên toàn bộ sheet. Em cần nó chỉ quét trên hình nào nó nằm ở cột K thôi

Em thay dòng bôi đậm phía trên thành " For Each pic In Sheet4.columns(11).Shapes" mà chạy không thấy gì cả

Đương nhiên là làm được, nhưng nói thật là tôi làm biếng sửa code khi không có file lắm (mất công đoán)
Vậy đi nha!

 

[hunglao]

Đương nhiên là làm được, nhưng nói thật là tôi làm biếng sửa code khi không có file lắm (mất công đoán)
Vậy đi nha!

Sorry bác

File nặng quá nên mình up lên đây


http://www.fshare.vn/file/6QZZS2GL66/

 

[ndu96081631]

Sorry bác

File nặng quá nên mình up lên đây


http://www.fshare.vn/file/6QZZS2GL66/

Code cũ là:

Sub Main()
  Dim pic As Shape, rngShp As Range, FSO As Object, IPicDisp As IPictureDisp
  Dim fileName As String
  On Error Resume Next
  Set FSO = CreateObject("Scripting.FileSystemObject")
  For Each pic In Sheet4.Shapes
    If pic.Type = msoPicture Then
      Set rngShp = ShapeRange(pic)
      fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
      If Not FSO.FileExists(fileName) Then
        'Set IPicDisp = PictureFromObject(pic, True)
        'SavePicture IPicDisp, fileName
      fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
      End If
    End If
  Next
End Sub

Sửa thành:

Sub Main()
  Dim pic As Shape, rngShp As Range, FSO As Object, IPicDisp As IPictureDisp
  Dim fileName As String
  On Error Resume Next
  Set FSO = CreateObject("Scripting.FileSystemObject")
  [COLOR=#ff0000]Dim rngTmp As Range[/COLOR]
  For Each pic In Sheet4.Shapes
    If pic.Type = msoPicture Then
      Set rngShp = ShapeRange(pic)
      [COLOR=#ff0000]Set rngTmp = Intersect(Sheet4.Columns(11), rngShp)[/COLOR]
      [COLOR=#ff0000]If Not rngTmp Is Nothing Then[/COLOR]
        fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
        If Not FSO.FileExists(fileName) Then
          'Set IPicDisp = PictureFromObject(pic, True)
          'SavePicture IPicDisp, fileName
          fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
        End If
      [COLOR=#ff0000]End If[/COLOR]
    End If
  Next
End Sub

Màu đỏ là những chỗ thêm vào

 

[hunglao]

Code cũ là:

Sub Main()
  Dim pic As Shape, rngShp As Range, FSO As Object, IPicDisp As IPictureDisp
  Dim fileName As String
  On Error Resume Next
  Set FSO = CreateObject("Scripting.FileSystemObject")
  For Each pic In Sheet4.Shapes
    If pic.Type = msoPicture Then
      Set rngShp = ShapeRange(pic)
      fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
      If Not FSO.FileExists(fileName) Then
        'Set IPicDisp = PictureFromObject(pic, True)
        'SavePicture IPicDisp, fileName
      fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
      End If
    End If
  Next
End Sub

Sửa thành:

Sub Main()
  Dim pic As Shape, rngShp As Range, FSO As Object, IPicDisp As IPictureDisp
  Dim fileName As String
  On Error Resume Next
  Set FSO = CreateObject("Scripting.FileSystemObject")
  [COLOR=#ff0000]Dim rngTmp As Range[/COLOR]
  For Each pic In Sheet4.Shapes
    If pic.Type = msoPicture Then
      Set rngShp = ShapeRange(pic)
      [COLOR=#ff0000]Set rngTmp = Intersect(Sheet4.Columns(11), rngShp)[/COLOR]
      [COLOR=#ff0000]If Not rngTmp Is Nothing Then[/COLOR]
        fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
        If Not FSO.FileExists(fileName) Then
          'Set IPicDisp = PictureFromObject(pic, True)
          'SavePicture IPicDisp, fileName
          fileName = ThisWorkbook.Path & "\" & Sheet4.Cells(rngShp.Row, 14).Value & ".jpg"
        End If
      [COLOR=#ff0000]End If[/COLOR]
    End If
  Next
End Sub

Màu đỏ là những chỗ thêm vào

CHuẩn như cơm mẹ nấu, cảm ơn anh

 

[ChuChuc]

Anh ơi cho em hỏi em đang dùng code PictureFromObject để chuyển Shape thành Image. vậy em muốn Zoom ảnh thì code như thế nào ạ.
Em cảm ơn anh