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

hunglao · 27/6/14

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

ndu96081631 · 27/6/14

hunglao đã viết:
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

Cụ thể là bạn muốn xuất thế nào?

hunglao · 27/6/14

Em muốn xuất hình ra file, với filename ở cột B, Xuất tự động 1 lúc cho toàn bộ hình trong file

ndu96081631 · 27/6/14

hunglao đã viết:
Em muốn xuất hình ra file, với filename ở cột B, Xuất tự động 1 lúc cho toàn bộ hình trong file

Nếu cột B là tên file, vậy sao nó trùng tùm lum thế? Và làm sao biết hình nào ứng với tên file nào?

hunglao · 27/6/14

ndu96081631 đã viết:
Nếu cột B là tên file, vậy sao nó trùng tùm lum thế? Và làm sao biết hình nào ứng với tên file nào?

Anh chỉ cần chọn một hàng bất kỳ chứa file ảnh đỏ.
Ví dụ hình đầu tiên, thì nằm từ hàng 3--> hàng số 8 . Tất cả đều ghi FS175--> Tên file

hunglao · 27/6/14

Hiện tại em có tìm dc 1 code có chức năng xuất tưng tự mà chưa biết cách hiệu chỉnh

ANh xem giúp em với

http://stackoverflow.com/questions/18232987/export-pictures-from-excel-file-into-jpg-using-vba

asipkc · 27/6/14

hunglao đã viết:
Hiện tại em có tìm dc 1 code có chức năng xuất tưng tự mà chưa biết cách hiệu chỉnh

ANh xem giúp em với

http://stackoverflow.com/questions/18232987/export-pictures-from-excel-file-into-jpg-using-vba

Bạn đưa file full lên xem nào
Mình làm cho bạn được rồi nhưng có rất nhiều vấn đề
Và vấn đề nghiêm trọng nhất là tên ảnh trùng nhau rất nhiều (không phải là tên ở cột B, chỗ đấy trùng ko sao, nhưng tên thật của ảnh chẳng hạn picture 5 có mấy file trùng tên như thế), và có một số ảnh có tên mà không thấy xuất hiện (có thể đã bị xóa đi). Khi duyệt nó sinh ra lỗi lên mình phải có 1 đoạn code index lại.

hunglao · 28/6/14

asipkc đã viết:
Bạn đưa file full lên xem nào
Mình làm cho bạn được rồi nhưng có rất nhiều vấn đề
Và vấn đề nghiêm trọng nhất là tên ảnh trùng nhau rất nhiều (không phải là tên ở cột B, chỗ đấy trùng ko sao, nhưng tên thật của ảnh chẳng hạn picture 5 có mấy file trùng tên như thế), và có một số ảnh có tên mà không thấy xuất hiện (có thể đã bị xóa đi). Khi duyệt nó sinh ra lỗi lên mình phải có 1 đoạn code index lại.

Gửi anh

file hơi lớn nên mình up lên đây

https://drive.google.com/file/d/0B2D9P9OCLYgvcDRqUDBIc0syclE/edit?usp=sharing

ndu96081631 · 28/6/14

hunglao đã viết:
Anh chỉ cần chọn một hàng bất kỳ chứa file ảnh đỏ.
Ví dụ hình đầu tiên, thì nằm từ hàng 3--> hàng số 8 . Tất cả đều ghi FS175--> Tên file

Bạn copy hết "đống" code này vào module:

Mã:

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
 
Private Type uPicDesc
  Size As Long
  Type As Long
  hPic As Long
  hPal As Long
End Type
     
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Function PictureFromObject(ByVal Target As Object, Optional ByVal bType As Boolean = True) As IPictureDisp
  Dim hPtr As Long, hCopy As Long, PicType As Long
  Const CF_BITMAP = 2
  Const CF_PALETTE = 9
  Const CF_ENHMETAFILE = 14
  Const IMAGE_BITMAP = 0
  Const LR_COPYRETURNORG = &H4
  Const PicType_BITMAP = 1
  Const PicType_ENHMETAFILE = 4
  Target.CopyPicture , IIf(bType, xlBitmap, xlPicture)
  PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
  If IsClipboardFormatAvailable(PicType) <> 0 Then
    If OpenClipboard(0) > 0 Then
      hPtr = GetClipboardData(PicType)
      If PicType = CF_BITMAP Then
        hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
      Else
        hCopy = CopyEnhMetaFile(hPtr, vbNullString)
      End If
      CloseClipboard
      If hPtr <> 0 Then
        Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
        With IID_IDispatch
          .Data1 = &H7BF80980
          .Data2 = &HBF32
          .Data3 = &H101A
          .Data4(0) = &H8B
          .Data4(1) = &HBB
          .Data4(2) = &H0
          .Data4(3) = &HAA
          .Data4(4) = &H0
          .Data4(5) = &H30
          .Data4(6) = &HC
          .Data4(7) = &HAB
        End With
        With uPicInfo
          .Size = Len(uPicInfo)
          .Type = IIf(PicType = CF_BITMAP, PicType_BITMAP, PicType_ENHMETAFILE)
          .hPic = hCopy
        End With
        OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
        Set PictureFromObject = IPic
      End If
    End If
  End If
End Function

Mã:

Function ShapeRange(ByVal shp As Shape) As Range
  On Error Resume Next
  Set ShapeRange = shp.Parent.Range(shp.TopLeftCell, shp.BottomRightCell)
End Function

Mã:

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 Sheet3.Shapes
    If pic.Type = msoPicture Then
      Set rngShp = ShapeRange(pic)
      fileName = ThisWorkbook.Path & "\" & Sheet3.Cells(rngShp.Row, 2).Value & ".bmp"
      If Not FSO.FileExists(fileName) Then
        Set IPicDisp = PictureFromObject(pic, True)
        SavePicture IPicDisp, fileName
      End If
    End If
  Next
End Sub

Xong, chạy sub Main là được (hoặc bấm nút Run Code trong file đính kèm)
--------------------
Lưu ý:
1> File hình được lưu cùng thư mục với file Tong hop 1.xls
2> Nếu muốn chạy code từ file đính kèm dưới đây thì bạn phải giải nén nó ra trước (không được chạy trực tiếp từ file .RAR)

hunglao · 28/6/14

Trên cả tuyệt vời, anh có thể chỉnh nó xuất ra file JPG với lại có thể chạy dc trên bản office 64 bit dc không a, em test với máy 32 thì Ok, máy 64 báo lỗi

ndu96081631 · 28/6/14

hunglao đã viết:
Trên cả tuyệt vời, anh có thể chỉnh nó xuất ra file JPG dc không a

Sửa đoạn:

Mã:

fileName = ThisWorkbook.Path & "\" & Sheet3.Cells(rngShp.Row, 2).Value & "[COLOR=#ff0000].bmp[/COLOR]"

thành:

Mã:

fileName = ThisWorkbook.Path & "\" & Sheet3.Cells(rngShp.Row, 2).Value & "[COLOR=#ff0000].jpg[/COLOR]"

là xong

hunglao đã viết:
với lại có thể chạy dc trên bản office 64 bit dc không a

Tôi không có Office 64 nên không test được, nhưng nói chung, nếu chạy Office 64 thì người ta sẽ sửa mấy đoạn Private Declare Function thành... gì gì đó (thêm PtrSafe gì gì đó)
Bạn có thể tra google để biết thêm chi tiết. Chẳng hạn là trang này:
http://msdn.microsoft.com/en-us/library/ff700513(v=office.11).aspx
Xem ví dụ và tự.. suy luận để sửa cho phù hợp

hunglao · 28/6/14

Cảm ơn anh

em sửa lại thế này là OK

Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As LongPrivate Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll"

hunglao · 28/6/14

ndu96081631 đã viết:
Sửa đoạn:

Mã:

fileName = ThisWorkbook.Path & "\" & Sheet3.Cells(rngShp.Row, 2).Value & "[COLOR=#ff0000].bmp[/COLOR]"

thành:

Mã:

fileName = ThisWorkbook.Path & "\" & Sheet3.Cells(rngShp.Row, 2).Value & "[COLOR=#ff0000].jpg[/COLOR]"

là xong

Tôi không có Office 64 nên không test được, nhưng nói chung, nếu chạy Office 64 thì người ta sẽ sửa mấy đoạn Private Declare Function thành... gì gì đó (thêm PtrSafe gì gì đó)
Bạn có thể tra google để biết thêm chi tiết. Chẳng hạn là trang này:
http://msdn.microsoft.com/en-us/library/ff700513(v=office.11).aspx
Xem ví dụ và tự.. suy luận để sửa cho phù hợp

ANh kiểm tra giùm

Em sửa code trên file đính kèm của a thì OK, còn copy qua file mới. tạo 1 modul rồi paste i chang code của file của anh thì click vào chạy mà không thấy gì cả

hunglao · 28/6/14

hunglao đã viết:
ANh kiểm tra giùm

Em sửa code trên file đính kèm của a thì OK, còn copy qua file mới. tạo 1 modul rồi paste i chang code của file của anh thì click vào chạy mà không thấy gì cả

OK rồi, em đổi tên sheet là dc

ndu96081631 · 28/6/14

hunglao đã viết:
OK rồi, em đổi tên sheet là dc

Cũng cần phải nói thêm về vấn đề Office 64 chút
Bạn nên sửa code thành thế này:

Mã:

#If VBA7 Then
'' Code dành cho Office 64
Private Declare PtrSafe  Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
#Else
'' Code dành cho Office 32
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
#End If

Thì nó sẽ chạy được trên cả Office 32 và 64 luôn

tedaynui · 29/6/14

ndu96081631 đã viết:
Cũng cần phải nói thêm về vấn đề Office 64 chút
Bạn nên sửa code thành thế này
Thì nó sẽ chạy được trên cả Office 32 và 64 luôn

Anh giúp em thế này: Thay vì xuất bảng tính ra Printer, bây giờ em muốn xuất bảng tính ra file ảnh JPG.

Nói cách khác, muốn xuất 1 Range trên bảng tính thành file ảnh JPG thì Codes thế nào?

Cảm ơn anh nhiều nhé.

ndu96081631 · 29/6/14

tedaynui đã viết:
Anh giúp em thế này: Thay vì xuất bảng tính ra Printer, bây giờ em muốn xuất bảng tính ra file ảnh JPG.

Nói cách khác, muốn xuất 1 Range trên bảng tính thành file ảnh JPG thì Codes thế nào?

Cảm ơn anh nhiều nhé.

Đầu tiên xem lại bài 7, ta có code thế này:

Mã:

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
 
Private Type uPicDesc
  Size As Long
  Type As Long
  hPic As Long
  hPal As Long
End Type
     
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Function PictureFromObject(ByVal Target As Object, Optional ByVal bType As Boolean = True) As IPictureDisp
''...................
End Function

Cứ copy hết code ấy vào module và áp dụng thế này:

Mã:

Sub Main()
  Dim rng As Range, IPicDisp As IPictureDisp, fileName As String
  Set rng = Range("A1:C10") ''thay đổi tùy ý
  Set IPicDisp = PictureFromObject(rng, True)
  fileName = ThisWorkbook.Path & "\test.jpg"  ''Hoặc đường dẫn nào đó tùy ý
  SavePicture IPicDisp, fileName
End Sub

Chỉ vậy thôi

tedaynui · 29/6/14

Ok rồi, cảm ơn Anh rất nhiều, hi hi

TDN

siwtom · 29/6/14

tedaynui đã viết:
Ok rồi, cảm ơn Anh rất nhiều, hi hi

TDN

Hỏi thật nhé. Bạn chạy code trên Excel nào? Bạn có chắc là bạn có tập tin JPG không?
Vì tôi chạy trên Excel 2007 thì không có JPG. Tức nếu đổi trong code & ".bmp" thành & ".jpg" thì tôi cũng có & ".jpg" nhưng lõi của nó vẫn là bitmap BMP.

Nếu là Excel 2007 (tôi không dám nói Excel khác vì tôi không có) thì dễ kiểm tra thôi. Nếu bạn so sánh (phải chuột --> properties) độ lớn 2 tập tin thì chúng như nhau. Nếu bạn có phần mềm so sánh (vd. ngày xưa dùng Total Commander) thì thấy không chỉ độ lớn mà 2 tập tin còn y hệt nhau.

Nhưng cách nhẹ nhàng là mở bằng hex editor. Tập tin bitmap BMP sẽ có 2 bai đầu là &H42, &H4D ("BM"). Đó là signature của bitmap BMP. JPG có "JFIF" ở mấy bai đầu. GIF có "GIF", "GIF89" ở ngay đầu.

Bạn hãy đổi code thành

Mã:

fileName = ThisWorkbook.Path & "\" & Sheet3.Cells(rngShp.Row, 2).Value & ".[B]avi[/B]"

Bạn có tin rằng SavePicture không "mè nheo", "phàn nàn" gì không? Nó sẽ ghi trên đĩa những tập tin "gì_đó.AVI". Nhưng đâu có phải là bạn sẽ có các tập tin video? Bạn nháy chuột vào thì sẽ thấy lỗi vì không có phần mềm video nào mở được tập tin AVI của bạn. Nhưng nếu phải chuột --> open as --> chọn Paint thì thấy ảnh. Như thế thì tên là AVI nhưng lõi là BMP.

Đấy là tôi chạy code trên Excel 2007 thì thế. Rất có thể trong Excel 2010, 2013 ghi thành JPG cũng được chăng? Nếu thế thì cho tôi xin thông tin là Excel nào. Rất có thể lúc đó nên chuyển sang Excel mới chăng?

tedaynui · 30/6/14

Đú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)

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ảm ơn bác siwtom nhé.

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

Thành viên hoạt động

File đính kèm

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Thành viên hoạt động

Thành viên mới

Thành viên hoạt động

Huyền thoại GPE

File đính kèm

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Thành viên hoạt động

File đính kèm

Thành viên hoạt động

Huyền thoại GPE

(*_*)

Huyền thoại GPE

(*_*)

Thành viên gắn bó

(*_*)

Đếm ngược thời gian

(_)

(_)

(_)