Tìm cách lưu ảnh từ Excel (1 người xem)

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Tôi tuân thủ nội quy khi đăng bài
Có
H

Hoang NS

Thành viên mới
Tham gia
27/8/24
Bài viết
9
Được thích
0
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 ??
 
Hoang NS đã viết:
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 ??
Nhấp chuột vào đây để mở rộng...
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.
 
snow25 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
mình không có file ảnh gốc, giờ chỉ muốn lưu lại ảnh từ file thôi
 
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.
 
Em úp file đó lên đây mới đánh giá chuẩn chỉ được. Phán bừa là nguy hiểm lắm.
 

File đính kèm

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.


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


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


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


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
Nhấp chuột vào đây để mở rộng...
Thanks anh để e thử ạ
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

Emyeuexcel
Tham chiếu về 1 ô-lấy ra và lọc dữ liệu (3 người xem)
Trả lời
3
Đọc
59
Emyeuexcel
Emyeuexcel
C
Fix lỗi Application.InputBox Type:=8 (16 người xem)
    • Cười
Trả lời
2
Đọc
58
cdshtz88
C
E
  • Question Question
VBA tự động thay đổi tham chiếu vùng (range và cell) khi insert dòng cột trong sheet tính toán (2 người xem)
    • Cười
Trả lời
5
Đọc
111
eagle12
E
L
Hỏi lỗi excel bị tràn trang khi in (2 người xem)
Trả lời
1
Đọc
52
Hoàng Tuấn 868
H
D
Tổng hợp dữ liệu từ các sheet sang sheet tổng (1 người xem)
Trả lời
3
Đọc
135
dohungmo
D
T
font chu trong excel (1 người xem)
Trả lời
2
Đọc
63
Hoàng Tuấn 868
H
khuong182018
  • Question Question
Nhờ anh chị sửa lỗi setfocus ở textbox (2 người xem)
Trả lời
9
Đọc
159
khuong182018
khuong182018
N
File chia băng tự động từ cuộn mẹ theo khổ băng và khối lượng băng cho trước (2 người xem)
Trả lời
0
Đọc
39
nguyenanhtruong2409
N
SA_DQ
Copilot bình luận về một ván cờ vua (2 người xem)
Trả lời
0
Đọc
69
SA_DQ
SA_DQ
T
Xin giúp đỡ lọc dữ liệu (1 người xem)
    • Cười
Trả lời
4
Đọc
109
pycckuu410
pycckuu410
Nguyễn Duy Tuân
[New] BSAC v3.0 bộ công cụ lập trình phần mềm chuyên nghiệp trong VBA
    • Thích
Trả lời
13
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Code Sổ Chi Tiết Tài Khoản
Trả lời
8
Đọc
319
hieuvietmy2020
H
befaint
Chia sẻ tâm tư, xả nỗi lòng (2 người xem)
    • Thích
6 7 8
Trả lời
778
Đọc
74K
SA_DQ
SA_DQ
H
Chia sẻ file in Phiếu điều tra PCGD (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
12
Đọc
440
HUONGHCKT
H
V
Hỏi công thức để làm khối lượng trong xây dựng. Xin cảm ơn (1 người xem)
Trả lời
11
Đọc
517
phanphu_91
P
Linhnv0001
Hỏi - Cách kiểm tra laptop là hàng lắp ráp hay không (1 người xem)
Trả lời
3
Đọc
272
Lê Duy Thương
Lê Duy Thương
K
Nhờ anh chị làm công thức lọc dữ kiện ngày từ bảng 1 sang rút gọn ngày ở bảng 2.
Trả lời
2
Đọc
184
Lê Duy Thương
Lê Duy Thương
L
[Mẹo] Không chọn Add-in vẫn có thể sử dụng được chức năng của Add-in, giảm tốc độ loading của Excel. (1 người xem)
    • Thích
Trả lời
2
Đọc
486
HeSanbi
HeSanbi
GPE-Trợ Lý
[GPE18] KỸ THUẬT BIỂU ĐỒ NÂNG CAO CHO DASHBOARD: TRỰC QUAN HÓA TIẾN ĐỘ THỰC HIỆN KẾ HOẠCH (1 người xem)
    • Thích
Trả lời
2
Đọc
9K
ptm0412
ptm0412
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (7 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
553
Đọc
72K
anh.nguyen287
anh.nguyen287
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom