excel里面图片导出来并重命名

shiwei_abc · 发表于 2014-6-11 16:57

图片导出并重命名.rar (1.01 MB, 下载次数: 617)
求助，我想把Excel里面的插入图片导出来，并放在新的文件夹里面，图片的名称是Excel里面图片对应的货号。
假如里面有无限不知道数量的图片，一个不落的都要导出来，谢谢了。

该贴已经同步到 shiwei_abc的微博

zhaogang1960 · 发表于 2014-6-11 17:13

请参考：

Sub 宏1()
Dim shp As Shape
With ActiveSheet
For Each shp In .Shapes
If shp.Type = 1 Then
shp.Copy
With .ChartObjects.Add(0, 0, shp.Width, shp.Height + 5).Chart
.Paste
.Export ThisWorkbook.Path & "" & shp.TopLeftCell.Offset(-1) & ".jpg"
.Parent.Delete
End With
End If
Next
End With
MsgBox "ok"
End Sub

复制代码

zhaogang1960 · 发表于 2014-6-11 17:15

请测试附件

图片导出并重命名.rar (1.02 MB, 下载次数: 1865)

shiwei_abc · 发表于 2014-6-11 17:17

zhaogang1960 发表于 2014-6-11 17:13
请参考：

谢谢回复，我先测试下

shiwei_abc · 发表于 2014-6-11 18:14

谢谢你们，测试成功，同时我有一个疑问，我用我的代码只能到处部分图片，用了你们的代码可以全部导出来，很奇怪，我把我的代码放出来，请你们帮忙找不足。
请参考：
Sub 导出图片()    ' 从excel中导出图片到文件夹
Dim i As Long
Dim nm$, n&, m&, fd
Dim cht As ChartObject
Dim sh As Shape
Dim strPath As String
Dim strPath2 As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
If fd.Show = -1 Then
      strPath = fd.SelectedItems(1) '选择之后就记录这个文件夹路径名称
End If

For i = 1 To ActiveSheet.Shapes.Count

      Set sh = ActiveSheet.Shapes(i)
      If sh.Type = 13 Then
      n = sh.TopLeftCell.Offset(-1, 0).Row
      m = sh.TopLeftCell.Offset(-1, 0).Column
      nm = Cells(n, m).Text
      sh.CopyPicture
      Set cht = ActiveSheet.ChartObjects.Add(0, 0, 150, 200)
      With cht
         .Chart.Paste
         .Chart.Shapes(1).Height = 200
         .Chart.Shapes(1).Width = 150
         If Len(nm) <> 0 Then strPath2 = strPath & "\" & nm & ".jpg"

         .Chart.Export strPath2, "JPG"

      End With
      End If

Next
End Sub

shiwei_abc · 发表于 2014-6-11 18:14

zhaogang1960 发表于 2014-6-11 17:13
请参考：

谢谢你们，测试成功，同时我有一个疑问，我用我的代码只能导出部分图片，用了你们的代码可以全部导出来，很奇怪，我把我的代码放出来，请你们帮忙找不足。
请参考：
Sub 导出图片()    ' 从excel中导出图片到文件夹
Dim i As Long
   Dim nm$, n&, m&, fd
   Dim cht As ChartObject
   Dim sh As Shape
   Dim strPath As String
   Dim strPath2 As String
   Set fd = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
   If fd.Show = -1 Then
      strPath = fd.SelectedItems(1) '选择之后就记录这个文件夹路径名称
   End If

For i = 1 To ActiveSheet.Shapes.Count

      Set sh = ActiveSheet.Shapes(i)
      If sh.Type = 13 Then
      n = sh.TopLeftCell.Offset(-1, 0).Row
      m = sh.TopLeftCell.Offset(-1, 0).Column
      nm = Cells(n, m).Text
      sh.CopyPicture
      Set cht = ActiveSheet.ChartObjects.Add(0, 0, 150, 200)
      With cht
         .Chart.Paste
         .Chart.Shapes(1).Height = 200
         .Chart.Shapes(1).Width = 150
         If Len(nm) <> 0 Then strPath2 = strPath & "\" & nm & ".jpg"

         .Chart.Export strPath2, "JPG"

      End With
      End If

Next
End Sub

shiwei_abc · 发表于 2014-6-11 18:18

zhaogang1960 发表于 2014-6-11 17:15
请测试附件

用可以用了，但是我Excel里面一共有93张图片，用你的宏可以导出63张，用我的宏可以导出30张，为什么不能全部导出来，很奇怪，希望您指教。

zhaogang1960 · 发表于 2014-6-11 18:21

shiwei_abc 发表于 2014-6-11 18:14
谢谢你们，测试成功，同时我有一个疑问，我用我的代码只能到处部分图片，用了你们的代码可以全部导出来，很 ...

Set cht = ActiveSheet.ChartObjects.Add(0, 0, 150, 200)
你限制了图片大小

zhaogang1960 · 发表于 2014-6-11 18:25

shiwei_abc 发表于 2014-6-11 18:18
用可以用了，但是我Excel里面一共有93张图片，用你的宏可以导出63张，用我的宏可以导出30张，为什么不能全 ...

这样试试看：

Sub 宏1()
Dim shp As Shape
With ActiveSheet
For Each shp In .Shapes
If shp.Type <> 8 Then '仅排除按钮
shp.Copy
With .ChartObjects.Add(0, 0, shp.Width, shp.Height + 5).Chart
.Paste
.Export ThisWorkbook.Path & "" & shp.TopLeftCell.Offset(-1) & ".jpg"
.Parent.Delete
End With
End If
Next
End With
MsgBox "ok"
End Sub

复制代码

shiwei_abc · 发表于 2014-6-11 18:34

zhaogang1960 发表于 2014-6-11 18:25
这样试试看：

大师，可以了，用了<>8，可以全部导出来，很好，但是我想知道为什么，知其然更要知其所以然。请指教

		自动登录	找回密码
密码			免费注册

[求助] excel里面图片导出来并重命名

评分