'---------------------------------------------------------------------------------------

' Module : mSaveObjectAsPicture

' DateTime : 05.03.2011 18:22

' Author : The_Prist(Щербаков Дмитрий)

' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

' http://www.excel-vba.ru

' Purpose : http://www.excel-vba.ru/chto-umeet-excel/kak-soxranit-kartinki-iz-lista-excel-v-kartinki-jpg/

'---------------------------------------------------------------------------------------

Option Explicit

'=============================================================================================

' Procedure : Range_to_Picture

' Author : The_Prist(Щербаков Дмитрий)

' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

' http://www.excel-vba.ru

' Purpose : Сохранить выделенный диапазон в картинку

'

'----------------------------------------------------------------------------------------------

Sub SaveRange_to_JPG()

Dim aTemp As Variant

Dim lngRowStart As Long, lngRowEnd As Long

With ThisWorkbook.Sheets("ListConfig_JPG")

lngRowStart = 2

lngRowEnd = .Columns(2).Rows(65536).End(xlUp).Row

aTemp = Range(.Cells(lngRowStart, 1), .Cells(lngRowEnd, 6)).Value

End With

Application.Calculation = xlCalculationAutomatic

FnRange_to_Picture aTemp, "jpg", "jpg"

End Sub

'----------------------------------------------------------------------------------------------

'сохраняем по выделенным в таблице именам листов

Sub SaveRange_to_XSLX_Selected()

Dim aTemp As Variant

Dim rRange As Range, rCell As Range

Dim lngRowStart As Long, lngRowEnd As Long

'проверки

If ActiveSheet.Name <> "ListConfig_JPG" Then Exit Sub

If ActiveCell.Column > 6 Then Exit Sub

Set rRange = Selection

With rRange

lngRowStart = .Row

lngRowEnd = lngRowStart

For Each rCell In .Cells 'цикл для поиск максимальной строки

If rCell.Row > lngRowEnd Then lngRowEnd = rCell.Row

Next 'rCell

End With

If Trim(Len(ActiveCell.Value)) = 0 Then Exit Sub

With ThisWorkbook.Sheets("ListConfig_JPG")

If lngRowStart = 0 Then lngRowStart = ActiveCell.Row

If lngRowEnd = 0 Then lngRowEnd = lngRowStart

aTemp = Range(.Cells(lngRowStart, 1), .Cells(lngRowEnd, 6)).Value

End With

Application.Calculation = xlCalculationAutomatic

FnRange_to_Picture aTemp, "xlsx", "xlsx"

End Sub

'----------------------------------------------------------------------------------------------

'сохраняем по выделенным в таблице именам листов

Sub SaveRange_to_XSLX_In_Sh()

Dim i As Long

Dim aTemp As Variant, vNamesSlide As Variant

Dim strSh As String

Dim lngRowStart As Long, lngRowEnd As Long

strSh = ActiveSheet.Name

With ThisWorkbook.Sheets("ListConfig_JPG")

lngRowStart = 2

lngRowEnd = .Columns(2).Rows(65536).End(xlUp).Row

vNamesSlide = Range(.Cells(lngRowStart, 1), .Cells(lngRowEnd, 6)).Value

End With

' цикл по всему списку листов

For i = LBound(vNamesSlide) To UBound(vNamesSlide)

'если имя совпадает, то набираем массив и выполняем сохранение

If Trim(vNamesSlide(i, 3)) = strSh Then

ReDim aTemp(1 To 1, 1 To 6)

aTemp(1, 1) = vNamesSlide(i, 1)

aTemp(1, 2) = vNamesSlide(i, 2)

aTemp(1, 3) = vNamesSlide(i, 3)

aTemp(1, 4) = vNamesSlide(i, 4)

aTemp(1, 5) = vNamesSlide(i, 5)

aTemp(1, 6) = vNamesSlide(i, 6)

Application.Calculation = xlCalculationAutomatic

FnRange_to_Picture aTemp, "xlsx", "xlsx"

End If

Next i

End Sub

'----------------------------------------------------------------------------------------------

Sub SaveRange_to_XSLX()

Dim aTemp As Variant

Dim lngRowStart As Long, lngRowEnd As Long

With ThisWorkbook.Sheets("ListConfig_JPG")

lngRowStart = 2

lngRowEnd = .Columns(2).Rows(65536).End(xlUp).Row

aTemp = Range(.Cells(lngRowStart, 1), .Cells(lngRowEnd, 6)).Value

End With

Application.Calculation = xlCalculationAutomatic

FnRange_to_Picture aTemp, "xlsx", "xlsx"

End Sub

'----------------------------------------------------------------------------------------------

Sub FnRange_to_Picture(ByVal vNamesSlide As Variant, _

ByVal strSubCatalog As String, _

ByVal strExt As String)

'Const strPathMain As String = "<path_to_folder_or_file>"

Const strPathMain As String = "<path_to_folder_or_file>"

Const strRangeMain As String = "$A$1:$BC$36"

Dim sName As String

Dim strFileName As String

Dim wsTmpSh As Worksheet

Dim rRange As Range

Dim i As Long

Dim strShName As String

Dim strRange As String

If Not IsArray(vNamesSlide) Then Exit Sub

'If TypeName(Selection) <> "Range" Then

' MsgBox "Выделенная область не является диапазоном!", vbCritical, "www.excel-vba.ru"

' Exit Function

'End If

'путь к папке

sName = strPathMain

If Len(strSubCatalog) > 0 Then sName = sName & strSubCatalog & "\"

'на входе в процедуру

Dim vCalculation As Variant

vCalculation = Application.Calculation

FnEventsValue 1, vCalculation

For i = LBound(vNamesSlide) To UBound(vNamesSlide)

strShName = vNamesSlide(i, 3)

strRange = vNamesSlide(i, 4)

If Len(strShName) > 0 Then

Set rRange = ThisWorkbook.Sheets(strShName).Range(strRange)

If vNamesSlide(i, 6) = 1 Then

With rRange

.CopyPicture

Select Case strExt

Case "jpg":

Set wsTmpSh = ThisWorkbook.Sheets.Add

strFileName = sName & "_" & vNamesSlide(i, 1) & "_" & vNamesSlide(i, 2) & ".jpg"

With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart

.ChartArea.Border.LineStyle = 0

.Paste

' .Export Filename:=sName & ".gif", FilterName:="GIF"

.Export Filename:=strFileName, FilterName:="JPG"

.Parent.Delete

End With

wsTmpSh.Delete

Case "xlsx"

'создать книгу+форматирование листа

Dim oWb As Workbook

Set oWb = Workbooks.Add

oWb.Sheets(1).Name = "1"

oWb.Sheets(1).Cells.ColumnWidth = 2.17

oWb.Sheets(1).Cells.RowHeight = 13.5

Dim rRangeMain As Range 'для определения размера картинки

Set rRangeMain = oWb.Sheets(1).Range(strRangeMain)

' Stop

'вставить изображение+подогнать размер

oWb.Sheets(1).Paste

oWb.Sheets(1).Shapes(1).LockAspectRatio = msoFalse

oWb.Sheets(1).Shapes(1).Width = rRangeMain.Width - 9 '730

oWb.Sheets(1).Shapes(1).Height = rRangeMain.Height - 9 '470

oWb.Sheets(1).Shapes(1).IncrementLeft 6 'сдвиг вправо

oWb.Sheets(1).Shapes(1).IncrementTop 6 'сдвиг вниз

Application.PrintCommunication = False

ActiveWindow.View = xlPageBreakPreview

oWb.Sheets(1).PageSetup.PrintArea = strRangeMain

oWb.Sheets(1).Range(strRangeMain).Interior.Color = vbWhite

oWb.Sheets(1).PageSetup.PrintErrors = xlPrintErrorsDisplayed

oWb.Sheets(1).PageSetup.Orientation = xlLandscape

oWb.Sheets(1).PageSetup.Zoom = 100

oWb.Sheets(1).PageSetup.FitToPagesWide = 1

oWb.Sheets(1).PageSetup.FitToPagesTall = 1

' .Zoom = False

' .FitToPagesWide = 1

' .FitToPagesTall = 1

Application.PrintCommunication = True

'сохранить в архив

strFileName = sName & "_" & vNamesSlide(i, 1) & "_" & vNamesSlide(i, 2) & ".xlsx"

'проверяем существование файла

On Error Resume Next

Dim FileExists As Boolean

FileExists = Dir(strFileName) <> vbNullString

If Err.Number > 0 Then Kill strFileName 'FileExists = False

On Error GoTo 0

oWb.SaveAs (strFileName), _

FileFormat:=xlOpenXMLWorkbook, _

Password:="", WriteResPassword:="", _

ReadOnlyRecommended:=False

oWb.Close

End Select

End With

End If

End If

Next i

'на выходе из процедуры

FnEventsValue 2, vCalculation

End Sub

'=============================================================================================

''---------------------------------------------------------------------------------------

'' Procedure : Save_Sel_Object_As_Picture

'' Author : The_Prist(Щербаков Дмитрий)

'' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'' http://www.excel-vba.ru

'' Purpose : Сохранение только выделенного объекта в формат GIF

''---------------------------------------------------------------------------------------

'Sub Save_Sel_Object_As_Picture()

' Dim sName As String, oObj As Object, wsTmpSh As Worksheet

' If VarType(Selection) <> vbObject Then

' MsgBox "Выделенная область не является объектом!", vbCritical, "www.excel-vba.ru"

' Exit Sub

' End If

' Application.ScreenUpdating = False

' Application.DisplayAlerts = False

' Set oObj = Selection: oObj.Copy

' Set wsTmpSh = ThisWorkbook.Sheets.Add

' sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_" & oObj.Name

' With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart

' .ChartArea.Border.LineStyle = 0

' .Paste

' .Export Filename:=sName & ".gif", FilterName:="GIF"

' .Parent.Delete

' End With

' wsTmpSh.Delete

' Application.ScreenUpdating = True

' Application.DisplayAlerts = True

'End Sub

''---------------------------------------------------------------------------------------

'' Procedure : Save_AllObjectsFromFiles_As_Picture

'' Author : The_Prist(Щербаков Дмитрий)

'' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'' http://www.excel-vba.ru

'' Purpose : Сохранение всех картинок из всех выбранных файлов Excel в папку

''---------------------------------------------------------------------------------------

'Sub Save_AllObjectsFromFiles_As_Picture()

' Dim avFiles, li As Long, oObj As Object, wsSh As Worksheet, wsTmpSh As Worksheet

' Dim sImagesPath As String, sBookName As String, sName As String

' Dim wbAct As Workbook

' Dim IsForEachWbFolder As Boolean

'

' avFiles = Application.GetOpenFilename("Excel Files(*.xls*),*.xls*", , "Выбрать файлы", , True)

' If VarType(avFiles) = vbBoolean Then Exit Sub

'

' IsForEachWbFolder = (MsgBox("Сохранять картинки каждой книги в отдельную папку?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes)

'

' If Not IsForEachWbFolder Then

' sImagesPath = Environ("userprofile") & "\desktop\images\" '"

' If Dir(sImagesPath, 16) = "" Then

' MkDir sImagesPath

' End If

' End If

' On Error Resume Next

' Application.ScreenUpdating = False

' Application.DisplayAlerts = False

' Set wsTmpSh = ThisWorkbook.Sheets.Add

' For li = LBound(avFiles) To UBound(avFiles)

' Set wbAct = Workbooks.Open(avFiles(li), False)

' 'создаем папку для сохранения картинок

' If IsForEachWbFolder Then

' sImagesPath = wbAct.Path & "\" & wbAct.Name & "_images\"

' If Dir(sImagesPath, 16) = "" Then

' MkDir sImagesPath

' End If

' End If

' sBookName = wbAct.Name

' For Each wsSh In Sheets

' For Each oObj In wsSh.Shapes

' If oObj.Type = 13 Then

' '13 - картинки

' '1 - автофигуры

' '3 - диаграммы

' oObj.Copy

' sName = ActiveWorkbook.Name & "_" & wsSh.Name & "_" & oObj.Name

' With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart

' .ChartArea.Border.LineStyle = 0

' .Paste

' .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"

' .Parent.Delete

' End With

' End If

' Next oObj

' Next wsSh

' wbAct.Close 0

' Next li

' Set oObj = Nothing: Set wsSh = Nothing

' wsTmpSh.Delete

' Application.DisplayAlerts = True

' Application.ScreenUpdating = True

' MsgBox "Объекты сохранены", vbInformation, "www.excel-vba.ru"

'End Sub

''---------------------------------------------------------------------------------------

'' Procedure : Range_to_Picture

'' Author : The_Prist(Щербаков Дмитрий)

'' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'' http://www.excel-vba.ru

'' Purpose : Сохранить выделенный диапазон в картинку

''

''---------------------------------------------------------------------------------------

'Sub Range_to_Picture()

' Dim sName As String, wsTmpSh As Worksheet

' If TypeName(Selection) <> "Range" Then

' MsgBox "Выделенная область не является диапазоном!", vbCritical, "www.excel-vba.ru"

' Exit Sub

' End If

' Application.ScreenUpdating = False

' Application.DisplayAlerts = False

' With Selection

' .CopyPicture

' Set wsTmpSh = ThisWorkbook.Sheets.Add

' sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"

' With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart

' .ChartArea.Border.LineStyle = 0

' .Paste

' .Export Filename:=sName & ".gif", FilterName:="GIF"

' .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"

' .Parent.Delete

' End With

' End With

' wsTmpSh.Delete

' Application.ScreenUpdating = True

' Application.DisplayAlerts = True

'End Sub

''---------------------------------------------------------------------------------------

'' Procedure : Save_AllObject_As_Picture_NamesToCells

'' Author : The_Prist(Щербаков Дмитрий)

'' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'' http://www.excel-vba.ru

'' Purpose : СОХРАНЯЕМ ВСЕ КАРТИНКИ С ЛИСТА В ПАПКУ С ЗАПИСЬЮ В ЯЧЕЙКИ ИМЕН КАРТИНОК

''---------------------------------------------------------------------------------------

'Sub Save_AllObject_As_Picture_NamesToCells()

' Dim li As Long, oObj As Shape, wsSh As Worksheet, wsTmpSh As Worksheet

' Dim sImagesPath As String, sName As String

'

' sImagesPath = ActiveWorkbook.Path & "\images\" '"

' If Dir(sImagesPath, 16) = "" Then

' MkDir sImagesPath

' End If

' On Error Resume Next

' Application.ScreenUpdating = False

' Application.DisplayAlerts = False

' Set wsSh = ActiveSheet

' Set wsTmpSh = ActiveWorkbook.Sheets.Add

' For Each oObj In wsSh.Shapes

' If oObj.Type = 13 Then

' li = li + 1

' oObj.Copy

' sName = "img" & li

' With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart

' .ChartArea.Border.LineStyle = 0

' .Paste

' .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"

' .Parent.Delete

' End With

' oObj.TopLeftCell.Value = sName

' oObj.Delete 'удаляем картинку с листа

' End If

' Next oObj

' Set oObj = Nothing: Set wsSh = Nothing

' wsTmpSh.Delete

' Application.DisplayAlerts = True

' Application.ScreenUpdating = True

' MsgBox "Объекты сохранены в папке: " & sImagesPath, vbInformation, "www.excel-vba.ru"

'End Sub

''---------------------------------------------------------------------------------------

'' Procedure : Save_Object_As_Picture_NamesFromCells

'' Author : The_Prist(Щербаков Дмитрий)

'' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'' http://www.excel-vba.ru

'' Purpose : Сохранить картинки с листа с именами картинок из ячеек

''---------------------------------------------------------------------------------------

'Sub Save_Object_As_Picture_NamesFromCells()

' Dim li As Long, oObj As Shape, wsSh As Worksheet, wsTmpSh As Worksheet

' Dim sImagesPath As String, sName As String

' Dim lNamesCol As Long, s As String

'

' s = InputBox("Укажите номер столбца с именами для картинок" & vbNewLine & _

' "(0 - столбец в котором сама картинка)", "www.excel-vba.ru", "")

' If StrPtr(s) = 0 Then Exit Sub

' lNamesCol = VAL(s)

'

' sImagesPath = ActiveWorkbook.Path & "\images\" '"

' If Dir(sImagesPath, 16) = "" Then

' MkDir sImagesPath

' End If

' ' On Error Resume Next

' Application.ScreenUpdating = False

' Application.DisplayAlerts = False

' Set wsSh = ActiveSheet

' Set wsTmpSh = ActiveWorkbook.Sheets.Add

' For Each oObj In wsSh.Shapes

' If oObj.Type = 13 Then

' oObj.Copy

' If lNamesCol = 0 Then

' sName = oObj.TopLeftCell.Value

' Else

' sName = wsSh.Cells(oObj.TopLeftCell.Row, lNamesCol).Value

' End If

' 'если в ячейке были символы, запрещенные

' 'для использования в качестве имен для файлов - удаляем

' sName = CheckName(sName)

' 'если sName в результате пусто - даем имя unnamed_ с порядковым номером

' If sName = "" Then

' li = li + 1

' sName = "unnamed_" & li

' End If

' With wsTmpSh.ChartObjects.Add(0, 0, oObj.Width, oObj.Height).Chart

' .ChartArea.Border.LineStyle = 0

' .Paste

' .Export Filename:=sImagesPath & sName & ".jpg", FilterName:="JPG"

' .Parent.Delete

' End With

' End If

' Next oObj

' Set oObj = Nothing: Set wsSh = Nothing

' wsTmpSh.Delete

' Application.DisplayAlerts = True

' Application.ScreenUpdating = True

' MsgBox "Объекты сохранены в папке: " & sImagesPath, vbInformation, "www.excel-vba.ru"

'End Sub

''---------------------------------------------------------------------------------------

'' Procedure : CheckName

'' Purpose : Функция проверки правильности имени

''---------------------------------------------------------------------------------------

'Function CheckName(sName As String)

' Dim objRegExp As Object

' Dim s As String

' Set objRegExp = CreateObject("VBScript.RegExp")

' objRegExp.Global = True: objRegExp.IgnoreCase = True

' objRegExp.Pattern = "[:,\\,/,?,\*,\<,\>,\',\|,""""]"

' s = objRegExp.Replace(sName, "")

' CheckName = s

'End Function

'