Tìm cách lưu ảnh từ Excel

[Hoang NS]

Các bác cho em hỏi có cách nào lưu toàn bộ ảnh trong 1 file Excel ra thành hình ảnh được không, file có 100 ảnh mà cần lưu lại ảnh ??

 

[snow25]

Các bác cho em hỏi có cách nào lưu toàn bộ ảnh trong 1 file Excel ra thành hình ảnh được không, file có 100 ảnh mà cần lưu lại ảnh ??

Bạn muốn lưu ảnh theo tên hay là lấy ảnh gốc khi up lên.Nếu lấy ảnh gốc thì đổi đuôi file excel về định dang Zip rồi tìm đến foder chứa ảnh là được.Còn nếu muốn lưu theo tên thì cần code VBA.

 

[Hoang NS]

Bạn muốn lưu ảnh theo tên hay là lấy ảnh gốc khi up lên.Nếu lấy ảnh gốc thì đổi đuôi file excel về định dang Zip rồi tìm đến foder chứa ảnh là được.Còn nếu muốn lưu theo tên thì cần code VBA.

mình không có file ảnh gốc, giờ chỉ muốn lưu lại ảnh từ file thôi

 

[HeSanbi]

Lưu hình ảnh trong tệp Excel ra thư mục, thì bạn muốn lưu tất cả file ảnh với tên từ đâu, cấu trúc tên như thế nào. Hay không cần quan tâm đến tên, chỉ cần có ảnh là được.

 

[Hoang NS]

Lưu hình ảnh trong tệp Excel ra thư mục, thì bạn muốn lưu tất cả file ảnh với tên từ đâu, cấu trúc tên như thế nào. Hay không cần quan tâm đến tên, chỉ cần có ảnh là được.

chỉ cần ra thành ảnh thôi ạ

 

[befaint]

Em úp file đó lên đây mới đánh giá chuẩn chỉ được. Phán bừa là nguy hiểm lắm.

 

[Hoang NS]

Em úp file đó lên đây mới đánh giá chuẩn chỉ được. Phán bừa là nguy hiểm lắm.

Em úp file đó lên đây mới đánh giá chuẩn chỉ được. Phán bừa là nguy hiểm lắm.

em muốn chia các ảnh này vào theo các ô và lưu nó ra thành từ ảnh riêng, em không biết về VBA ạ !

 

[befaint]

em muốn chia các ảnh này vào theo các ô và lưu nó ra thành từ ảnh riêng, em không biết về VBA ạ !

File em gửi không phải tập tin Excel. File không mở được.

 

[HeSanbi]

Bạn gán macro ExportXLImages_test dưới đây vào một nút nhấn, chép mã vào một Module mới và lưu lại với dạng xlsm.
Nhấn nút chọn tệp Excel cần thực hiện.

'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'


Private Const projectClassName = "ExportXLImages"
Private Const projectClassVersion = "1.03"
Option Compare Text
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Sub ExportXLImages_test()
  On Error Resume Next
  Dim file$, dest$, sheets, fd, b As Boolean
  Set fd = Application.FileDialog(3)
  fd.AllowMultiSelect = False
  If fd.Show = -1 Then file = fd.SelectedItems(1)
  If file <> "" Then
    b = ExportXLImages(file, dest)
    ActiveWorkbook.FollowHyperlink dest, , True
    MsgBox IIf(b, "Thanh Cong!", "Ko thanh Cong!")
  End If
End Sub


Private Function ExportXLImages(fileName$, Optional destDirectories$) As Boolean
  On Error Resume Next
  If fileName = "" Then Exit Function
  Dim file$, file2$
  Dim s$, oFile As Object, b As Boolean
  Dim oSh, ms2, FSo As Object, tPath, fn$, app As Object
  Dim it, ZipFile, ext$, xl_type&, fn2$, p2$

  Set FSo = glbFSO
  Set oSh = glbShellA
  '-----------------------------------------------
  file = fileName:
  Select Case True
  Case file Like "*.xla": xl_type = 18: ext = ".xla": b = True
  Case file Like "*.xlsb": xl_type = 50: ext = ".xlsb": b = True
  Case file Like "*.xlsx": xl_type = 51: ext = ".xlsx"
  Case file Like "*.xlsm": xl_type = 52: ext = ".xlsm"
  Case file Like "*.xlam": xl_type = 55: ext = ".xlam"
  Case file Like "*.xls": xl_type = 56: ext = ".xls": b = True
  Case Else: Exit Function
  End Select
 
  If Not destDirectories Like "*[\/]" And destDirectories <> "" Then destDirectories = destDirectories & "\"
  With FSo
    Set oFile = .GetFile(file)
    If oFile Is Nothing Then Exit Function
    fn = oFile.Name
    If b Then fn = Replace(fn, ext, ".xlsx", , , 1): ext = ".xlsx"
    fn2 = Left(fn, Len(fn) - Len(ext))
    If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\"
    tPath = Environ$("temp") & "\VBE\ExportXLImages\"
    CreateFolder tPath & "xl\", FSo
    p2 = destDirectories & "media " & fn2 & "\"
    CreateFolder p2, FSo
    ZipFile = tPath & fn & ".zip"

    If b Then
      Set app = CreateObject("Excel.Application")
      With app
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = -4135
        With .Workbooks.Open(fileName:=file, UpdateLinks:=False, ReadOnly:=True)
          .SaveAs ZipFile, 51: .Close False
        End With
        .Quit
      End With
      Set app = Nothing
    Else
      .copyFile file, ZipFile, True
    End If
    err.Clear: DoEvents:
    
    err.Clear:  oSh.Namespace(CVar(p2)).movehere oSh.Namespace(CVar(ZipFile & "\xl\media\")).items, 4 Or 16
    
    ExportXLImages = err = 0
    .GetFolder(tPath).Delete
E:
  End With
End Function

Private Function glbFSO() As Object
  Set glbFSO = CreateObject("Scripting.FileSystemObject")
End Function
Private Function glbShellA() As Object
  Set glbShellA = CreateObject("Shell.Application")
End Function
Private Function CreateFolder(ByVal folderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, Tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = folderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  If FileSystem Is Nothing Then Set FileSystem = glbFSO
  On Error GoTo Ends
  FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      Tmp = Tmp & FolderArray(i) & "\"
      If Not .FolderExists(Tmp) Then DoEvents: .CreateFolder (Tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function

 

[Hoang NS]

Bạn gán macro ExportXLImages_test dưới đây vào một nút nhấn, chép mã vào một Module mới và lưu lại với dạng xlsm.
Nhấn nút chọn tệp Excel cần thực hiện.

'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'


Private Const projectClassName = "ExportXLImages"
Private Const projectClassVersion = "1.03"
Option Compare Text
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Sub ExportXLImages_test()
  On Error Resume Next
  Dim file$, dest$, sheets, fd, b As Boolean
  Set fd = Application.FileDialog(3)
  fd.AllowMultiSelect = False
  If fd.Show = -1 Then file = fd.SelectedItems(1)
  If file <> "" Then
    b = ExportXLImages(file, dest)
    ActiveWorkbook.FollowHyperlink dest, , True
    MsgBox IIf(b, "Thanh Cong!", "Ko thanh Cong!")
  End If
End Sub


Private Function ExportXLImages(fileName$, Optional destDirectories$) As Boolean
  On Error Resume Next
  If fileName = "" Then Exit Function
  Dim file$, file2$
  Dim s$, oFile As Object, b As Boolean
  Dim oSh, ms2, FSo As Object, tPath, fn$, app As Object
  Dim it, ZipFile, ext$, xl_type&, fn2$, p2$

  Set FSo = glbFSO
  Set oSh = glbShellA
  '-----------------------------------------------
  file = fileName:
  Select Case True
  Case file Like "*.xla": xl_type = 18: ext = ".xla": b = True
  Case file Like "*.xlsb": xl_type = 50: ext = ".xlsb": b = True
  Case file Like "*.xlsx": xl_type = 51: ext = ".xlsx"
  Case file Like "*.xlsm": xl_type = 52: ext = ".xlsm"
  Case file Like "*.xlam": xl_type = 55: ext = ".xlam"
  Case file Like "*.xls": xl_type = 56: ext = ".xls": b = True
  Case Else: Exit Function
  End Select
 
  If Not destDirectories Like "*[\/]" And destDirectories <> "" Then destDirectories = destDirectories & "\"
  With FSo
    Set oFile = .GetFile(file)
    If oFile Is Nothing Then Exit Function
    fn = oFile.Name
    If b Then fn = Replace(fn, ext, ".xlsx", , , 1): ext = ".xlsx"
    fn2 = Left(fn, Len(fn) - Len(ext))
    If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\"
    tPath = Environ$("temp") & "\VBE\ExportXLImages\"
    CreateFolder tPath & "xl\", FSo
    p2 = destDirectories & "media " & fn2 & "\"
    CreateFolder p2, FSo
    ZipFile = tPath & fn & ".zip"

    If b Then
      Set app = CreateObject("Excel.Application")
      With app
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = -4135
        With .Workbooks.Open(fileName:=file, UpdateLinks:=False, ReadOnly:=True)
          .SaveAs ZipFile, 51: .Close False
        End With
        .Quit
      End With
      Set app = Nothing
    Else
      .copyFile file, ZipFile, True
    End If
    err.Clear: DoEvents:
   
    err.Clear:  oSh.Namespace(CVar(p2)).movehere oSh.Namespace(CVar(ZipFile & "\xl\media\")).items, 4 Or 16
   
    ExportXLImages = err = 0
    .GetFolder(tPath).Delete
E:
  End With
End Function

Private Function glbFSO() As Object
  Set glbFSO = CreateObject("Scripting.FileSystemObject")
End Function
Private Function glbShellA() As Object
  Set glbShellA = CreateObject("Shell.Application")
End Function
Private Function CreateFolder(ByVal folderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, Tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = folderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  If FileSystem Is Nothing Then Set FileSystem = glbFSO
  On Error GoTo Ends
  FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      Tmp = Tmp & FolderArray(i) & "\"
      If Not .FolderExists(Tmp) Then DoEvents: .CreateFolder (Tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function

Thanks anh để e thử ạ