Exportador de Imagenes 90%

Option Explicit

Public Sub AbrirLibrosv3()

    Dim img As Shape

    Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object

    Dim Fichero As Object, tmpFichero As Object

    Dim strRutaInicial As String



    strRutaInicial = "D:\Check_List_Hold_Point"


    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fCarpeta = fso.GetFolder(strRutaInicial)


    For Each tmpFichero In fCarpeta.Files

    If LCase(Mid(tmpFichero.Name, InStr(tmpFichero.Name, ".") + 1)) = "xlsx" Then
        Workbooks.Open tmpFichero.Path

        Application.ScreenUpdating = False



        Application.ScreenUpdating = True

        ActiveWorkbook.Close savechanges:=False
    End If

    Next tmpFichero


    Recursivo strRutaInicial

End Sub


Private Sub Recursivo(ByVal RutaInicial As String)

    Dim fso As Object, fCarpeta As Object, tmpCarpeta As Object

    Dim Fichero As Object, tmpFichero As Object

    Dim ruta As String
    Dim hojaActual As Worksheet
    Dim graficoActual As ChartObject
    ' Dim img As Shape
    Dim strTempName As String
    Dim objHolder As ChartObject
    Dim PicWidth As Long, PicHeight As Long
    Dim MyChart As String, MyPicture As String

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fCarpeta = fso.GetFolder(RutaInicial)

    ruta = "D:\Graficos\"

    For Each tmpCarpeta In fCarpeta.SubFolders

        For Each tmpFichero In tmpCarpeta.Files

            If LCase(Mid(tmpFichero.Name, InStr(tmpFichero.Name, ".") + 1)) = "xlsx" Then
                Workbooks.Open tmpFichero.Path

                Application.ScreenUpdating = False

                For Each hojaActual In Sheets

                    For Each img In hojaActual.Shapes
                         On Error Resume Next
                         img.Select

                         MyPicture = Selection.Name
                         With Selection
                            PicHeight = .ShapeRange.Height
                            PicWidth = .ShapeRange.Width
                         End With

                         Charts.Add
                         ActiveChart.Location Where:=xlLocationAsObject, Name:=hojaActual.Name
                         Selection.Border.LineStyle = 0
                         MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)

                         With ActiveSheet
                           With .Shapes(MyChart)
                                 .Width = PicWidth
                                 .Height = PicHeight
                           End With

                           .Shapes(MyPicture).Copy

                           With ActiveChart
                                 .ChartArea.Select
                                 .Paste
                           End With

                           .ChartObjects(1).Chart.Export ruta & hojaActual.Name & "-" & img.Name & ".jpg", "jpg"
                           .Shapes(MyChart).Cut
                        End With


'                        ' img.SaveAsPicture ruta & hojaActual.Name & "-" & img.Name & ".jpg", "jpg"
'                        ' img.Chart.Export ruta & hojaActual.Name & "-" & img.Name & ".png", "png"
'
'
'                        strTempName = img.Name
'                        Set objHolder = ActiveSheet.ChartObjects(strTempName)
'                        objHolder.Chart.Export ruta & hojaActual.Name & "-" & img.Name & ".jpg", "jpg"
'

                    Next

'                    For Each graficoActual In hojaActual.ChartObjects
'                        graficoActual.Chart.Export ruta & hojaActual.Name & "-" & graficoActual.Name & ".png", "png"
'                    Next

'                    For Each xx In hojaActual.Shapes
'                        On Error Resume Next
'                        xx.Select
'
'                    Next
                Next

                Application.ScreenUpdating = True


                ActiveWorkbook.Close savechanges:=False
            End If

        Next

        Recursivo tmpCarpeta.Path

    Next tmpCarpeta

End Sub