论坛 › Excel 动画教程 › 关于从Excel中批量导出图片，并按Excel中名称命名，求完善

f13145205920 发表于 2013-10-9 09:41

关于从Excel中批量导出图片，并按Excel中名称命名，求完善

本帖最后由 f13145205920 于 2013-10-9 13:34 编辑

前面有同事让帮从Excel中批量导出图片，
并按Excel中的名称加规格命名，
发现网上很多资料都只有批量导出的，
但同时按要求命名的确没有找到。
于是，只好用自己仅有的一点点VBA知识，弄出这个粗糙的代码。
这个代码没有自动建立存放导出图片的文件夹，需要事先手动建立一个文件夹。
且，如果Excel中的图片如果太不规范，也会有问题。不过只要偏移量不超过其图片的2/3也是没有问题的。

希望有人可以补充完善。
Sub zldccmx()
    Dim obj As Object
    Dim name
    Dim arr
    arr = Array("\", "/", "|", "< ", " > ", "~*")
    For i = LBound(arr) To UBound(arr)
      Cells.Replace What:=arr(i), Replacement:="-", LookAt:=xlPart, SearchOrder _
      :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next i
    x = InputBox("请输入图片所在行的上一行行号:") + 0
    a = InputBox("请输入图片所在列的列列号:") + 0
    y = InputBox("请输入要图片命名信息存放的列号:") + 0
    Z = InputBox("请输入要图片命名信息存放的次列号:") + 0
   
    Application.ScreenUpdating = False
   
    With ActiveSheet
      name = .name
      h = .Rows(x + 1 & ":" & x + 1).RowHeight
      .Rows("1:" & .Range("B65536").End(3).Row).RowHeight = h
      
      b = 1
      For Each obj In ActiveSheet.Shapes
            k = obj.Top
            l = obj.Left
            m = obj.Height
            n = Application.Round((k + m) / h, 0)
      With .Shapes(b)
             .LockAspectRatio = msoFalse
             .Top = Cells(n, a).Top
             .Left = Cells(n, a).Left
             .Width = Cells(n, a).Width
             .Height = Cells(n, a).Height
      End With
      b = b + 1
      Next obj
   
    End With
    For Each obj In ActiveSheet.Shapes
            k = obj.Top
            l = obj.Height
            m = obj.Left
            n = obj.Width
      Select Case obj.Left
      Case m To m + n
            j = y
            Select Case obj.Top
            Case k To k + l
                i = Application.RoundUp(k / (h - 1), 0)
            End Select
         End Select
      obj.Select
      obj.Copy
      If Z = 0 Then
            F_n = "D:\导出图片\" & Cells(i, j).Value & ".jpg"
      Else
            F_n = "D:\导出图片\" & Cells(i, j).Value & "(" & Cells(i, Z).Value & ")" & ".jpg"
      End If
      Charts.Add
      With ActiveChart
            .ChartType = xlColumnClustered
            .Location Where:=xlLocationAsObject, name:=name
      End With
      With Selection
            .Border.LineStyle = 0
            .Interior.ColorIndex = xlNone
      End With
      '贴图/导出图像/并删除刚刚建立的图表对象
      ActiveChart.Paste
      With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
            .Height = obj.Height * 2
            .Width = obj.Width * 2
      End With
            ActiveChart.Shapes.Range(Array("Picture 1")).Select
                Selection.ShapeRange.Height = 213
                Selection.ShapeRange.Width = 369
         Worksheets(name).ChartObjects(ChartObjects.Count).Chart.Export F_n, "JPG"
      ActiveSheet.ChartObjects.Delete
    Next obj
   
    Application.ScreenUpdating = True

    MsgBox ("图片导出完毕！")

End Sub

f13145205920 发表于 2013-10-9 13:36

本帖最后由 f13145205920 于 2013-10-9 13:37 编辑


难道不设回复可见就没人回复吗？

aarondzy 发表于 2014-11-16 20:58

我是来学习的

QQ_3F70F1 发表于 2014-11-18 21:04

{:1_1:}{:1_1:}{:1_1:}{:1_1:}我下载了，就是没太看懂，应该是不错的东西

吴雨生 发表于 2021-6-7 10:49

学习

查看完整版本: 关于从Excel中批量导出图片，并按Excel中名称命名，求完善