I get an excel report each week with images in the comments.
I am trying to loop through all comments in the file, and paste all the comments to the worksheet as pictures
I have tried the method found on the "Ku Tools" website...
https://www.extendoffice.com/documents/excel/4328-excel-extract-image-from-comment.html
Here is the code from the website (that i use exactly)...
Sub CommentPictures()
'Updateby Extendoffcie 20161207
Dim cmt As Comment
Dim xRg As Range
Dim visBool As Boolean
Dim cmtTxt As String
Dim jpgPath As String
Dim shpHeight As Integer, shpWidth As Integer
Application.ScreenUpdating = False
For Each cmt In ActiveSheet.Comments
With cmt
cmtTxt = .Text
shpHeight = .Shape.Height
shpWidth = .Shape.Width
.Text Text:="" & Chr(10) & ""
visBool = .Visible
.Visible = True
On Error Resume Next
Set xRg = .Parent.Offset(0, 1)
.Shape.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
xRg.PasteSpecial
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Width = xRg.Width
Selection.Height = xRg.Height
.Visible = visBool
.Text Text:=cmtTxt
End With
Next cmt
Application.ScreenUpdating = True
End Sub
When I use this code, it works sporadically
When it "doesn't work", the macro creates an invisible rectangle object
When it does work, it creates a visible rectangle image/object (rectangle shape that can be seen).
In the below screenshot, row 715 contains a visible image (when the macro works right) and row 755 contains an invisible image (when it doesn't work right)
Visible vs Non-Visible
I want to make all 700+ image comments actual images as easily as possible, if anyone has any ideas, they would be greatly appreciated.
My hypothesis is that there might be a size limit, because the macro worked perfectly when I ran it in a small batch of a couple dozen images
Thanks
Related
G'day all, I'm trying to create a button that opens the dialogue box, allows the user to
select a photo from their files,
embeds that file to the particular cell that the button exists in,
and allows it to move and size along with that cell, while maintaining aspect ratio (thanks for the pickup dbmitch)
I have successfully done that using the expression.Insert.Picture() method, but had a rude surprise when I sent the sheet out and all the pictures were replaced with "Photo has been moved, deleted or edited." It seems this method only links the file, which certainly won't work for me, so now I'm trying the much older method of expression.shapes.addPicture(). I think I am successfully adding the photo, but can't seem to get the sizing or locking to cell to work. Please see both attempts below-
Sub GetPic()
Dim fNameAndPath As Variant
Dim img As Picture
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
If fNameAndPath = False Then Exit Sub
Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
With img
'Resize Picture to fit in the range....
.Left = ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Left
.Top = ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Top
.Width = ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Width
.Height = ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Height
.Placement = 1
.PrintObject = True
End With
End Sub
Sub TestPic()
Dim ws As Worksheet, s As Shape
Set ws = ActiveSheet
' Insert the image.
Set s = ws.Shapes.AddPicture(Application.GetOpenFilename(Title:="Please work"), _
False, True, ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Left, _
ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Top, _
ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Width, _
ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Height)
' Use picture's height and width.
End Sub
I was able to get this code to run in Excel 2016 VBA. You don't say where you're running this from but I assume Application.Caller is not from a module? Maybe a Userform?
Here's what worked for me - hopefully you can use it
Sub TestPic()
Dim ws As Worksheet, s As Shape
Dim sngLeft As Single, sngRight As Single, sngTop As Single, sngWidth As Single
Set ws = ActiveSheet
' Insert the image.
With ActiveCell.Cells
sngLeft = .Left
sngTop = .Top
sngWidth = .Width
sngheight = .Height
End With
Set s = ws.Shapes.AddPicture(Application.GetOpenFilename(Title:="Please work"), _
msoFalse, msoTrue, sngLeft, sngTop, sngWidth, sngheight)
s.Placement = xlMoveAndSize ' move and resize when cell dimensions change
'ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Left, _
'ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Top, _
'ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Width, _
'ActiveSheet.Range(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Address).Height)
' Use picture's height and width.
End Sub
I'm working on a project using VBA with Excel. By clicking a button, we generate an array. One line refers to one product. The information is stored in each column (column A = reference, column B = name...). The generation is made with some code using VBA.
The problem concerns the pictures. I managed the shape of the pictures, so they are placed in the cell, with a certain height, width, placement...
When I generate the array from my computer, there's no problem, the pictures are placed perfectly.
When the array is generated from another computer, the pictures look stretched and shifted. That's it from the 12th line to the end (but the first 11 lines are okay). I don't understand why it starts from the 12th line because the code is exactly the same for every line of the array. And above all, I don't understand why the array isn't well generated on every computer.
The Excel version is the same and the pictures options too.
Have you heard about something like that?
Thanks a lot for your comments!
Here's the code:
Function SetImageViewer(Ref As String, Cell As Range) As String
Dim cmt As Comment
Dim sPicName As String
Dim ImageCell As Range
Dim OrderFormWS As Worksheet
sPicName = GetParameter("PicturesPath") & "\" & Ref & ".jpg"
Set ImageCell = Cell.MergeArea
Set OrderFormWS = ThisWorkbook.Sheets("OrderForm")
sPicFile = Dir(sPicName)
If sPicFile <> vbNullString Then
Set Pic = OrderFormWS.Shapes.AddPicture(sPicName, linktofile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=0, Top:=0, Width:=0, Height:=0)
With Pic
.LockAspectRatio = msoTrue
.Left = ImageCell.Left + 5
.Top = ImageCell.Top + 5
.Width = 40
.Height = 40
.Placement = xlMoveAndSize
End With
Set cmt = Cell.Comment
If cmt Is Nothing Then Set cmt = Cell.AddComment()
cmt.Text " "
cmt.Shape.Fill.UserPicture sPicName
cmt.Shape.Height = 300
cmt.Shape.Width = 300
SetImageViewer = ChrW(&H25BA)
Else
Set cmt = Cell.Comment
If Not cmt Is Nothing Then cmt.Delete
SetImageViewer = "No picture"
End If
End Function
First of all I'm not very good at Excel macro.
After going through multiple forums, I managed to come up with a code to Crop images in a folder using Excel VBA.
the code opens up each image in Excel, paste in a chart, crop the image, resize to match the height & width and then replace the original image with the edited image.
Macro is working fine with F8 but when I run the macro fully, Images are not getting replaced with the edited one, instead it's replacing with blank image.
After digging through multiple options, the only conclusion I came up with is the macro is running fine in Excel 2013 but it's not running properly with office 365.
Can anybody help me, how to resolve this or have any better code to run?
Option Explicit
Sub ImportData()
Dim XL As Object
Dim thisPath As String
Dim BooksPAth As String
BooksPAth = "C:\Images\"
thisPath = ActivePresentation.path
Set XL = CreateObject("Excel.Application")
Run "Crop_vis", BooksPAth
End Sub
Sub DeleteAllShapes()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
Next Shp
End Sub
Sub Crop_Vis(ByVal folderPath As String)
Dim Shp As Object, path As String, sht As Worksheet, s As Shape, TempChart As String
'Dim folderPath As String
Application.ScreenUpdating = True
If folderPath = "" Then Exit Sub
Set sht = Sheet1
sht.Activate
sht.Range("A10").Activate
path = Dir(folderPath & "\*.jpg")
Do While path <> ""
DeleteAllShapes
Set Shp = sht.Pictures.Insert(folderPath & "\" & path)
' Use picture's height and width.
Set s = sht.Shapes(sht.Shapes.Count)
s.PictureFormat.CropTop = 50
s.Width = 768
s.Height = 720
'Add a temporary chart in sheet1
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=sht.Name
Selection.Border.LineStyle = 0
TempChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With sht
'Change the dimensions of the chart to suit your need
With .Shapes(TempChart)
.Width = s.Width
.Height = s.Height
End With
'Copy the picture
s.Copy
'Paste the picture in the chart
With ActiveChart
.ChartArea.Select
.Paste
End With
'Finally export the chart
.ChartObjects(1).Chart.Export fileName:=folderPath & "\" & path, FilterName:="jpg"
'Destroy the chart. You may want to delete it...
.Shapes(TempChart).Cut
End With
path = Dir
Loop
DeleteAllShapes
Application.DisplayAlerts = False
End Sub
Before
'Finally export the chart
insert something like this, to make sure that pasting of the image into the chart has finished:
Do
If ActiveChart.Shapes.Count > 0 Then
Exit Do
End If
Loop
The problem is with the pasting. When you tell it to paste the clipboard (image) into the chart, sometimes it ignores you. When you go to export the chart, you end up with an empty image.
It's not that you have to wait for it to paste, because it's not going to - it ignored you. I have no idea why it ignores you, or why it doesn't error out when it ignores you - it just ignores you with no warning. Maybe Windows is just too busy under the hood to paste.
Basically, what you have to do is check to see if it pasted, and if not, paste again....and again....until it finally sees fit to process your instruction.
I debugged, Googled, trialed and errored and banged my head on the wall for week on this and finally ended up with this:
Sub SavePictureFromExcel(shp As Shape, SavePath As String)
Dim Imagews As Worksheet
Dim tempChartObj As ChartObject
Dim ImageFullPath As String
Set Imagews = Sheets("Image Files")
Set tempChartObj = Imagews.ChartObjects.Add(0, 0, shp.Width, shp.Height)
shp.Copy
tempChartObj.Chart.ChartArea.Format.Line.Visible = msoFalse 'No Outline
tempChartObj.Chart.ChartArea.Format.Fill.Visible = msoFalse 'No Background
Do
DoEvents
tempChartObj.Chart.Paste
Loop While tempChartObj.Chart.Shapes.Count < 1
ImageFullPath = SavePath & "\" & shp.Name & ".png"
tempChartObj.Chart.Export ImageFullPath, Filtername:="png"
tempChartObj.Delete
End Sub
This question already has answers here:
How to resize all images on a worksheet?
(2 answers)
Closed 3 years ago.
Ok i have an image that a 3rd part software is placing into an excel file. in order to get the resolution needed it has to be sized much larger than needed. It will always be placed in the same location and be a specific size. I need to resize it. Ideally it would be automatic when the excel file opens but i think any vba code would end up acting before the information is inserted, but if there was a small delay that would be cool too. Alternatively i could make do with a button that runs a bit of code. The code below works, but only when the picture is specifically named "Picture 179" which it won't be ever again or at least until the counter recycles.
The image is inserted at Cell A45 specifically but it extends through roughly cell AZ60.
Here is what i've got that doesn't work.
Private Sub Resize_Graph_Click()
ActiveSheet.Shapes.Range(Array("Picture 179")).Select
Selection.ShapeRange.Height = 104.4
Selection.ShapeRange.Width = 486.72
End Sub
You still need to work out when to resize the picture, but the example code below shows how you can specifically access a picture where the Top-Left corner of the picture is located within a given cell.
Option Explicit
Sub TestMe()
Dim thePicture As Shape
Set thePicture = GetPictureAt(Range("A45"))
If Not thePicture Is Nothing Then
Debug.Print "found it! (" & thePicture.Name & ")"
With thePicture
.Height = 75
.Width = 75
Debug.Print "resized to h=" & .Height & ", w=" & .Width
End With
Else
Debug.Print "couldn't find the picture!"
End If
End Sub
Private Function GetPictureAt(ByRef thisCell As Range) As Shape
Dim thisCellTop As Long
Dim thisCellBottom As Long
Dim thisCellLeft As Long
Dim thisCellRight As Long
With thisCell
thisCellTop = .Top
thisCellLeft = .Left
thisCellBottom = thisCellTop + .Height
thisCellRight = thisCellLeft + .Width
End With
Dim shp As Variant
With Sheet1
For Each shp In .Shapes
If shp.Type = msoPicture Then
If (shp.Top >= thisCellTop) And (shp.Top <= thisCellBottom) Then
If (shp.Left >= thisCellLeft) And (shp.Left <= thisCellRight) Then
Set GetPictureAt = shp
Exit Function
End If
End If
End If
Next shp
End With
End Function
Here is what i settled on.
Private Sub Resize_Graph_Click()
'resize all shapes
Dim s As Shape
Dim ws As Worksheet
Set ws = ActiveSheet
For Each s In ActiveSheet.Shapes
s.LockAspectRatio = msoFalse
s.Width = 491.72
s.Height = 106.56
Next s
'set header shapes and button back to original size
ActiveSheet.Shapes.Range(Array("Company Label")).Select
Selection.ShapeRange.Height = 43.92
Selection.ShapeRange.Width = 131.76
ActiveSheet.Shapes.Range(Array("Product Label")).Select
Selection.ShapeRange.Height = 49.68
Selection.ShapeRange.Width = 134.64
ActiveSheet.Shapes.Range(Array("Resize_Graph")).Select
ActiveSheet.Shapes("Resize_Graph").Height = 38.16
ActiveSheet.Shapes("Resize_Graph").Width = 105.12
'keep button from moving after changing shape back and forth
ActiveSheet.Shapes.Range(Array("Resize_Graph")).Select
ActiveSheet.Shapes("Resize_Graph").Left = 380
ActiveSheet.Shapes("Resize_Graph").Top = 5
ActiveWorkbook.Close Savechanges:=True
End Sub
I am trying to print out section, that is marked as Printarea. This code however sometimes runs good and sometimes it doesn't. There is really no rule with it. The question is, how can I make it 100% runnable.
What it does when it runs good. It prints the area, saves it as Picture and then quits.
What it does when it doesn't. It prints blank white page without any data on it, as if printing blank page. The fact that the page prints, evethough its blank suggests that the saving is not a problem.
Can you help?
OK, I will reveal my cards. This started as "learning this area of VBA" project (printing saving pictures), so I tried to pull data from website about my arrival to work and then printing what day it is, how far are we with the week so far etc. The whole code is revealed since the fixed range helped a bit, but I still get blank pages in 10% of cases when ran manually and 50% of cases when ran after win start via vbs script. basically I noticed that stressed CPU is in direct correlation to succesful code run. All files are local except for the website pull which is always succesful.
VBS:
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.Run "'*someCorporatePath\newStart.xlsb'!Module1.Auto_Open"
objExcel.DisplayAlerts = False
objExcel.Application.Quit
Set objExcel = Nothing
Module 1
Option Explicit
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
Public Const SPIF_UPDATEINIFILE = &H1
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Auto_Open()
Call getDataFromWebsite
Call weekProgress
Call saveSheet
Call changeWallpaper
Application.DisplayAlerts = False
Application.Quit
End Sub
Sub getDataFromWebsite()
Dim x As String
Dim IE As Object
Dim HtmlCon As HTMLDocument
Dim element As Object
Dim ArrivalTime
On Error GoTo Handler
x = "*Some-secret-corporate-website*"
Set IE = New InternetExplorerMedium
IE.Navigate (x)
IE.Visible = False
Do While IE.ReadyState <> 4
DoEvents
Loop
Set HtmlCon = IE.document
Set element = HtmlCon.getElementsByClassName("*someAJAXcorporateElement*")
ArrivalTime = element(0).innerText
ThisWorkbook.Sheets(1).Cells(3, 15).Value = ArrivalTime
Handler:
IE.Quit
End Sub
Sub weekProgress()
Dim caseResult As String
Dim offsetDayIndex As Integer
Const dayBarLenght = 2
Select Case Application.WorksheetFunction.Weekday(Date, 2)
Case 1
caseResult = "Monday"
offsetDayIndex = 0
Case 2
caseResult = "Tuesday"
offsetDayIndex = 1
Case 3
caseResult = "Wednesday"
offsetDayIndex = 2
Case 4
caseResult = "Thursday"
offsetDayIndex = 3
Case 5
caseResult = "Friday"
offsetDayIndex = 4
Case Else
caseResult = "Monday"
End Select
DoEvents
ThisWorkbook.Sheets(1).Cells(24, 11).Value = caseResult
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 12)).Interior.ColorIndex = 1
If Not caseResult = "Monday" Then
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 4 + (dayBarLenght * offsetDayIndex))).Interior.ColorIndex = 2
End If
End Sub
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
Dim intLastRow As Integer
Dim intLastCol As Integer
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
With ThisWorkbook.Sheets(1)
.PageSetup.PrintArea = .Range("A1", .Cells(37, 17)).Address
End With
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="*MyCorporatePath*", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
Sub changeWallpaper()
Dim strImagePath As String
strImagePath = "*MyCorporatePath*"
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub
Requirement: To save the PrintArea of the first worksheet as a bmp file.
Original procedure:
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="C:\Users\insertyourname\Pictures\savedImage.bmp", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
The procedure as originally stated in the post creates a range named area using the PageSetup.PrintArea property as the reference for the range.
If the PrintAreais set to the entire sheet then the PrintArea property would be equal to an empty string and the instruction below will generate an error.
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
As the procedure is printing a blank page, we can assume that the PrintArea property is a valid A1-style reference.
The printing of a blank page when the PageSetup.PrintArea property is a valid A1-style reference could be replicated at least in the following cases:
1. When the range corresponding to the PrintArea is in fact a range of empty cells,
2. When the range corresponding to the PrintArea has its rows or columns hidden,
3. When printing a chart and although the rows and columns of the chart are visible the rows or columns of the Chart.SourceData are hidden, thus the chart is blank.
The original procedure has been adjusted in order to ask the user to validate the output and if the output is blank them it presents the user with the printed range (i.e. the Print.Area) so the necessary corrections can be applied.
Sub Save_PrintArea_As_bmp()
Dim ws As Worksheet
Dim oCht As Object
Dim ddZoomCoef As Double
Dim rArea As Range
Set ws = ThisWorkbook.Worksheets(1) 'Modify as required
With ws
ddZoomCoef = 100 / .Parent.Windows(1).Zoom
Set rArea = .Range(.PageSetup.PrintArea)
rArea.CopyPicture xlPrinter
Set oCht = .ChartObjects.Add(0, 0, _
rArea.Width * ddZoomCoef, rArea.Height * ddZoomCoef)
End With
Application.DisplayAlerts = False
With oCht
.Chart.Paste
If MsgBox("Is the printed page blank?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
"Save PrintArea As bmp") = vbYes Then
.Delete
MsgBox "This is the PrintArea, validate that the range is visible."
With ws
.Activate
Application.Goto .Cells(1), 1
Application.Goto rArea
Exit Sub
Application.DisplayAlerts = True
End With
Else
.Chart.Export Filename:="D:\#D_Trash\savedImage.bmp", _
Filtername:="bmp" 'Modify as required
.Delete
End If: End With
Application.DisplayAlerts = True
End Sub
It sounds like you want to save an image of the area that would be printed, even if the user has not specified a print area. The problem is that Excel has no .PrintArea value if one has not been specified by a user. See below for further details.
To ensure the code works as intended, you can either stop the code early if no print area has been set:
If ThisWorkbook.Sheets(1).PageSetup.PrintArea = vbNullString Then
MsgBox "No print area has been set.", vbCritical, "Save Sheet"
Exit Sub
End If
Or you can set the print area manually to include all values by placing this at the start of the macro:
Dim intLastRow as Integer
Dim intLastCol As Integer
With ThisWorkbook.Sheets(1)
If .PageSetup.PrintArea = vbNullString Then
intLastRow = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False).Row
intLastCol = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
MatchCase:=False).Column
.PageSetup.PrintArea = .Range("A1", .Cells(intLastRow, intLastCol)).Address
End If
End With
Note that this closely mimics the default print area to start from A1, but does not include more distant cells that include only formatting or objects. This is likely sufficient for your needs, but it could be adjusted further if you didn't want it to start from A1 or if you need to include cells that contain only formatting or objects.
Notes on "Default Print Area"
There isn't strictly a default print area determined by Excel at the time of printing. It instead prints as many continuous pages as necessary to include all cells that contain any values, formatting or objects, starting from A1 (regardless of where content starts). This is not necessarily a rectangular area and the number of pages printed can depend on the print order. It also does not necessarily include all cells in the .UsedArea
For example, enter a value in W15 (3 pages to the right) and E70 (1 page down). If printing without setting a print area, Excel will start with a blank page from A1. The default print order setting of down-then-across will result in 5 pages being printed from the layout below: Pages 1,4,2,5,3. Changing to print across-then-down will result in only 4 pages being printed: Pages 1,2,3,4. Manually setting the print area instead results in all 6 pages being printed in whichever order is specified.
Upon learning, that Chart.Paste is causing the problem and upon researching in web I found that Chart.Paste is broken terribly in VBA itself. One has to manually activate it through the code. I also found that the printarea is no longer needed since I just passed the desired range to PrintArea and then wrote the PrintArea value to another unknown. So here is the code, that fixes the buggy Chart.Paste
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area As Range
Dim intLastRow As Integer
Dim intLastCol As Integer
Dim chartName As String
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = Range("A1", Cells(37, 17))
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
DoEvents
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
DoEvents
chartName = oCht.Chart.Name
ThisWorkbook.Sheets(1).Activate 'this one **********
oCht.Activate 'this one too ***********
Application.Wait (Now + TimeValue("0:00:02"))
oCht.Chart.Paste
Application.Wait (Now + TimeValue("0:00:02"))
DoEvents
oCht.Chart.Export Filename:="somePath", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub