好几天了解决不了，请各位大神今天一定帮看看

howell2023

1. Sub outpic()
   
2.   Dim strpath As String, strpicname As String, strwhere As String, strpicfullname As String
   
3.   Dim shp As Shape, k As Long, d As Object, x As String, y As Long, numpic As Long
   
4.   With Application.FileDialog(msoFileDialogFolderPicker)
   
5.      If .Show Then strpath = .SelectedItems(1) Else: Exit Sub
   
6.   End With
   
7.   strwhere = InputBox("请输入图片名称相对应图片所在单元格的偏移位置，例如上1、下1、左1、右1", , "左1") '用户输入图片相对单元格的偏移位置。
   
8.   If Len(strwhere) = 0 Then Exit Sub
   
9.   x = Left(strwhere, 1) '偏移的方向
   
10.   If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位！": Exit Sub
    
11.   y = Val(Mid(strwhere, 2)) '偏移的值
    
12.   Set d = CreateObject("scripting.dictionary")
    
13.   Application.ScreenUpdating = False
    
14. numpic = 0
    
15. For Each shp In ActiveSheet.Shapes
    
16.      If shp.Type = msoPicture Then
    
17.          strpicname = getpicname(x, y, shp.TopLeftCell)
    
18.          If Not d.exists(strpicname) Then
    
19.             d(strpicname) = 1
    
20.          Else
    
21.             d(strpicname) = d(strpicname) + 1
    
22.             strpicname = strpicname & d(strpicname)
    
23.          End If
    
24.          strpicfullname = strpath & "" & strpicname & ".jpg"
    
25.          shp.Copy
    
26.          numpic = numpic + 1
    
27.         
    
28.          With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
    
29.               .Parent.Select
    
30.             
    
31.               .Paste
    
32.               .Export strpicfullname, "jpg"
    
33.               .Parent.Delete
    
34.          End With
    
35.       End If
    
36. Next
    
37. Application.ScreenUpdating = True
    
38. MsgBox "共导出" & numpic & "张图片" & Chr(13) & "路径：" & strpath, , "提示"
    
39. 
    
40.   
    
41.   
    
42. End Sub
    
43. Function getpicname(x As String, y As Long, rngshape As Range) As String
    
44.     Dim strpicname As String
    
45.     Select Case x
    
46.         Case "上"
    
47.         strpicname = rngshape.Offset(-y, 0).Value
    
48.         Case "下"
    
49.         strpicname = rngshape.Offset(y, 0)
    
50.         Case "左"
    
51.         strpicname = rngshape.Offset(0, -y)
    
52.         Case "右"
    
53.         strpicname = rngshape.Offset(0, y)
    
54.     End Select
    
55.     getpicname = IIf(strpicname = "", "图片", strpicname)
    
56. 
    
57.    
    
58. End Function
    

复制代码

好几天了解决不了，我要取图片的原始大小，然后保存，但现在是只取我缩小后的图片，逻辑是对的，但我想取原始大小的图片然后保存

lujkhua

请测试：

1. Sub outpic()
   
2.     Dim strpath As String, strpicname As String, strwhere As String, strpicfullname As String
   
3.     Dim shp As Shape, k As Long, d As Object, x As String, y As Long, numpic As Long
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         If .Show Then strpath = .SelectedItems(1) Else: Exit Sub
   
6.     End With
   
7.     strwhere = InputBox("请输入图片名称相对应图片所在单元格的偏移位置，例如上1、下1、左1、右1", , "左1") '用户输入图片相对单元格的偏移位置。
   
8.     If Len(strwhere) = 0 Then Exit Sub
   
9.     x = Left(strwhere, 1) '偏移的方向
   
10.     If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位！": Exit Sub
    
11.     y = Val(Mid(strwhere, 2)) '偏移的值
    
12.     Set d = CreateObject("scripting.dictionary")
    
13.     Application.ScreenUpdating = False
    
14.     numpic = 0
    
15.     For Each shp In ActiveSheet.Shapes
    
16.         If shp.Type = msoPicture Then
    
17.             strpicname = getpicname(x, y, shp.TopLeftCell)
    
18.             If Not d.exists(strpicname) Then
    
19.                 d(strpicname) = 1
    
20.             Else
    
21.                 d(strpicname) = d(strpicname) + 1
    
22.                 strpicname = strpicname & d(strpicname)
    
23.             End If
    
24.             strpicfullname = strpath & "" & strpicname & ".jpg"
    
25.             numpic = numpic + 1
    
26.             H = shp.Height
    
27.             W = shp.Width
    
28.             shp.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
    
29.             shp.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
    
30.             shp.CopyPicture
    
31.             With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
    
32.                 .Paste
    
33.                 .Export strpicfullname, "jpg"
    
34.                 .Parent.Delete
    
35.             End With
    
36.             shp.Height = H
    
37.             shp.Width = W
    
38.         End If
    
39.     Next
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "共导出" & numpic & "张图片" & Chr(13) & "路径：" & strpath, , "提示"
    
42. End Sub
    
43. Function getpicname(x As String, y As Long, rngshape As Range) As String
    
44.     Dim strpicname As String
    
45.     Select Case x
    
46.     Case "上"
    
47.         strpicname = rngshape.Offset(-y, 0).Value
    
48.     Case "下"
    
49.         strpicname = rngshape.Offset(y, 0)
    
50.     Case "左"
    
51.         strpicname = rngshape.Offset(0, -y)
    
52.     Case "右"
    
53.         strpicname = rngshape.Offset(0, y)
    
54.     End Select
    
55.     getpicname = IIf(strpicname = "", "图片", strpicname)
    
56. End Function

复制代码

howell2023

Sub outpic()     Dim strpath As String, strpicname As String, strwhere As String, strpicfullname As String     Dim shp As Shape, k As Long, d As Object, x As String, y As Long, numpic As Long     With Application.FileDialog(msoFileDialogFolderPicker)         If .Show Then strpath = .SelectedItems(1) Else: Exit Sub     End With     strwhere = InputBox("请输入图片名称相对应图片所在单元格的偏移位置，例如上1、下1、左1、右1", , "左1") '用户输入图片相对单元格的偏移位置。     If Len(strwhere) = 0 Then Exit Sub     x = Left(strwhere, 1) '偏移的方向     If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位！": Exit Sub     y = Val(Mid(strwhere, 2)) '偏移的值     Set d = CreateObject("scripting.dictionary")     Application.ScreenUpdating = False     numpic = 0     For Each shp In ActiveSheet.Shapes         If shp.Type = msoPicture Then             strpicname = getpicname(x, y, shp.TopLeftCell)             If Not d.exists(strpicname) Then                 d(strpicname) = 1             Else                 d(strpicname) = d(strpicname) + 1                 strpicname = strpicname & d(strpicname)             End If             strpicfullname = strpath & "\" & strpicname & ".jpg"             numpic = numpic + 1             H = shp.Height             W = shp.Width             shp.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft             shp.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft             shp.CopyPicture             With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart                 .Parent.Select                 .Paste                 .Export strpicfullname, "jpg"                 .Parent.Delete             End With             shp.Height = H             shp.Width = W         End If     Next     Application.ScreenUpdating = True     MsgBox "共导出" & numpic & "张图片" & Chr(13) & "路径：" & strpath, , "提示" End Sub Function getpicname(x As String, y As Long, rngshape As Range) As String     Dim strpicname As String     Select Case x     Case "上"         strpicname = rngshape.Offset(-y, 0).Value     Case "下"         strpicname = rngshape.Offset(y, 0)     Case "左"         strpicname = rngshape.Offset(0, -y)     Case "右"         strpicname = rngshape.Offset(0, y)     End Select     getpicname = IIf(strpicname = "", "图片", strpicname) End Function

howell2023

1. Sub outpic()
   
2.     Dim strpath As String, strpicname As String, strwhere As String, strpicfullname As String
   
3.     Dim shp As Shape, k As Long, d As Object, x As String, y As Long, numpic As Long
   
4.     With Application.FileDialog(msoFileDialogFolderPicker)
   
5.         If .Show Then strpath = .SelectedItems(1) Else: Exit Sub
   
6.     End With
   
7.     strwhere = InputBox("请输入图片名称相对应图片所在单元格的偏移位置，例如上1、下1、左1、右1", , "左1") '用户输入图片相对单元格的偏移位置。
   
8.     If Len(strwhere) = 0 Then Exit Sub
   
9.     x = Left(strwhere, 1) '偏移的方向
   
10.     If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位！": Exit Sub
    
11.     y = Val(Mid(strwhere, 2)) '偏移的值
    
12.     Set d = CreateObject("scripting.dictionary")
    
13.     Application.ScreenUpdating = False
    
14.     numpic = 0
    
15.     For Each shp In ActiveSheet.Shapes
    
16.         If shp.Type = msoPicture Then
    
17.             strpicname = getpicname(x, y, shp.TopLeftCell)
    
18.             If Not d.exists(strpicname) Then
    
19.                 d(strpicname) = 1
    
20.             Else
    
21.                 d(strpicname) = d(strpicname) + 1
    
22.                 strpicname = strpicname & d(strpicname)
    
23.             End If
    
24.             strpicfullname = strpath & "" & strpicname & ".jpg"
    
25.             numpic = numpic + 1
    
26.             H = shp.Height
    
27.             W = shp.Width
    
28.             shp.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
    
29.             shp.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
    
30.             shp.CopyPicture
    
31.             With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
    
32.                 .Parent.Select
    
33.                 .Paste
    
34.                 .Export strpicfullname, "jpg"
    
35.                 .Parent.Delete
    
36.             End With
    
37.             shp.Height = H
    
38.             shp.Width = W
    
39.         End If
    
40.     Next
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "共导出" & numpic & "张图片" & Chr(13) & "路径：" & strpath, , "提示"
    
43. End Sub
    
44. Function getpicname(x As String, y As Long, rngshape As Range) As String
    
45.     Dim strpicname As String
    
46.     Select Case x
    
47.     Case "上"
    
48.         strpicname = rngshape.Offset(-y, 0).Value
    
49.     Case "下"
    
50.         strpicname = rngshape.Offset(y, 0)
    
51.     Case "左"
    
52.         strpicname = rngshape.Offset(0, -y)
    
53.     Case "右"
    
54.         strpicname = rngshape.Offset(0, y)
    
55.     End Select
    
56.     getpicname = IIf(strpicname = "", "图片", strpicname)
    
57. End Function
    
58. 最终修改后完整的，终于解决了，谢谢lujkhua

复制代码