Здравствуйте уважаемые форумчане. Необходимо решить не простую задачу, не знаю, есть ли ее техническая возможность решения, вопрос вот в чем. Приложенный файл пример имеет два листа. Необходимо с помощью программы сохранить их в виде рисунка в формате .jpg в границах печати, т.е. грубо говоря заменив распечатывание и сканирование программой, если решение такой задачи есть, то если возможно второй лист без открытия. Заранее спасибо..
Здравствуйте уважаемые форумчане. Необходимо решить не простую задачу, не знаю, есть ли ее техническая возможность решения, вопрос вот в чем. Приложенный файл пример имеет два листа. Необходимо с помощью программы сохранить их в виде рисунка в формате .jpg в границах печати, т.е. грубо говоря заменив распечатывание и сканирование программой, если решение такой задачи есть, то если возможно второй лист без открытия. Заранее спасибо..Sashagor1982
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Declare Function OpenClipboard _ Lib "user32" ( _ ByVal hwnd As Long _ ) As Long Private Declare Function GetClipboardData _ Lib "user32" ( _ ByVal wFormat As Integer _ ) As Long Private Declare Function CloseClipboard _ Lib "user32" ( _ ) As Long Private Declare Function OleCreatePictureIndirect _ Lib "olepro32.dll" ( _ PicDesc As uPicDesc, _ RefIID As GUID, _ ByVal fPictureOwnsHandle As Long, _ IPic As IPicture _ ) As Long Const CF_BITMAP = 2 Const PICTYPE_BITMAP = 1 Dim strPictureFile As String Public Sub SaveSheetAsImage(sh As Worksheet) Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture Dim hPtr As Long Dim FilePathName$ sh.UsedRange.CopyPicture Appearance:=xlScreen, format:=xlBitmap FilePathName = Application.GetSaveAsFilename("%homepath%\Pictures\", "Рисунок в формате GPEG (*.jpg), *.jpg", , "Сохраненеие изображения", "Сохранить") If FilePathName = "False" Then Exit Sub OpenClipboard 0 hPtr = GetClipboardData(CF_BITMAP) CloseClipboard With IID_IDispatch .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(2) = &H0 .Data4(3) = &HAA .Data4(4) = &H0 .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With With uPicinfo .Size = Len(uPicinfo) .Type = PICTYPE_BITMAP .hPic = hPtr .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic SavePicture IPic, FilePathName End Sub
[/vba]
в модуле ЭтаКнига [vba]
Код
Sub SaveSheets() Dim sh As Worksheet For Each sh In Sheets SaveSheetAsImage sh Next End Sub
[/vba] [p.s.]правда, наверно, это не совсем то, что нужно, думаю вам поможет виртуальный принтер (например BullZip)
можно как-то так
[vba]
Код
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Declare Function OpenClipboard _ Lib "user32" ( _ ByVal hwnd As Long _ ) As Long Private Declare Function GetClipboardData _ Lib "user32" ( _ ByVal wFormat As Integer _ ) As Long Private Declare Function CloseClipboard _ Lib "user32" ( _ ) As Long Private Declare Function OleCreatePictureIndirect _ Lib "olepro32.dll" ( _ PicDesc As uPicDesc, _ RefIID As GUID, _ ByVal fPictureOwnsHandle As Long, _ IPic As IPicture _ ) As Long Const CF_BITMAP = 2 Const PICTYPE_BITMAP = 1 Dim strPictureFile As String Public Sub SaveSheetAsImage(sh As Worksheet) Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture Dim hPtr As Long Dim FilePathName$ sh.UsedRange.CopyPicture Appearance:=xlScreen, format:=xlBitmap FilePathName = Application.GetSaveAsFilename("%homepath%\Pictures\", "Рисунок в формате GPEG (*.jpg), *.jpg", , "Сохраненеие изображения", "Сохранить") If FilePathName = "False" Then Exit Sub OpenClipboard 0 hPtr = GetClipboardData(CF_BITMAP) CloseClipboard With IID_IDispatch .Data1 = &H7BF80980 .Data2 = &HBF32 .Data3 = &H101A .Data4(0) = &H8B .Data4(1) = &HBB .Data4(2) = &H0 .Data4(3) = &HAA .Data4(4) = &H0 .Data4(5) = &H30 .Data4(6) = &HC .Data4(7) = &HAB End With With uPicinfo .Size = Len(uPicinfo) .Type = PICTYPE_BITMAP .hPic = hPtr .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic SavePicture IPic, FilePathName End Sub
[/vba]
в модуле ЭтаКнига [vba]
Код
Sub SaveSheets() Dim sh As Worksheet For Each sh In Sheets SaveSheetAsImage sh Next End Sub
[/vba] [p.s.]правда, наверно, это не совсем то, что нужно, думаю вам поможет виртуальный принтер (например BullZip) krosav4ig
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 & ".jpg", FilterName:="JPG" .Parent.Delete End With End With wsTmpSh.Delete Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
[/vba]
Спасибо. Данный макрос в принципе работает как надо, только подскажите, как его доработать, что бы сохранялась не выделенная область, а например лист в границах печати?
[vba]
Код
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 & ".jpg", FilterName:="JPG" .Parent.Delete End With End With wsTmpSh.Delete Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
[/vba]
Спасибо. Данный макрос в принципе работает как надо, только подскажите, как его доработать, что бы сохранялась не выделенная область, а например лист в границах печати?Sashagor1982