[help] Hướng dẫn lưu tất cả ảnh trong file word ra 1 thư mục (2 người xem)

[vsxmm]

Mình có 1 fiile word có chứa các hình ảnh.

Nếu mình làm thủ công là mình kích chuột phải vào ảnh và chọn chức năng save as picture là được.

Mình muốn dùng VBA để tự động xuất hết hình ảnh trong file ra 1 thư mục với tên là Hinh01, Hinh02, Hinh03,…


Mong các anh chị em giúp đỡ với. Cảm ơn nhiều! Dưới đây là file đính kèm ạ.

 

[ppc0312]

Mình có 1 fiile word có chứa các hình ảnh.

Nếu mình làm thủ công là mình kích chuột phải vào ảnh và chọn chức năng save as picture là được.

Mình muốn dùng VBA để tự động xuất hết hình ảnh trong file ra 1 thư mục với tên là Hinh01, Hinh02, Hinh03,…


Mong các anh chị em giúp đỡ với. Cảm ơn nhiều! Dưới đây là file đính kèm ạ.

File / Save AS ....
Chọn "Web Page (.htm) " cho phần "File Format"

thành Zip file --> bấm vào xả ra là thấy các ảnh images

 

[HeSanbi]

Đổi tên file thành HoiVBA.rar hoặc HoiVBA.zip sau đó giải nén thành thư mục

Ảnh nằm trong đường dẫn:
...\HoiVBA\word\media

-----------------------
Để sử dụng code: Yêu cầu Cài Win7z, copy code vào một module của ứng dụng Office.

Sub GetMediaInWord()
  On Error Resume Next
  Dim FSO As Scripting.FileSystemObject, SH As Object, Word As Object
  Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
  Set SH = VBA.CreateObject("Shell.Application")
  Set Word = VBA.GetObject(, "Word.Application")
  ''------------------------------------------------
  Dim fWord As String, pWord As String, eWord As String, nWord As String, pTemp As String
  fWord = Word.ActiveDocument.FullName
  pWord = Word.ActiveDocument.Path & "\" '
  eWord = FSO.GetExtensionName(fWord)
  nWord = Word.ActiveDocument.name
  nWord = VBA.Left(nWord, Len(nWord) - Len(eWord) - 1)
  pTemp = pWord
  ''------------------------------------------------
  FSO.DeleteFile pTemp & nWord & ".zip"
  FSO.CopyFile fWord, pTemp & nWord & ".zip", True
  FSO.CreateFolder pTemp & nWord
  ''------------------------------------------------
  SH.Namespace(CVar(pTemp & nWord)).CopyHere SH.Namespace(CVar(pTemp & nWord & ".zip")).items, &H10&
  ''------------------------------------------------
  Dim K As Integer
  Do
    If FSO.FolderExists(pTemp & nWord & "\word\media\") Then
      FSO.DeleteFile pTemp & nWord & ".zip", True
      shell "explorer.exe """ & pWord & """", vbNormalFocus
      Exit Do
    End If
    K = K + 1: If K > 10 Then Exit Do
    Application.Wait VBA.Now + VBA.TimeSerial(0, 0, 1)
  Loop
  On Error GoTo 0
Ends: Set FSO = Nothing
      Set SH = Nothing
      Set Word = Nothing
End Sub