Copy range and paste into MS Paint

[ARbitOUR]

Hi all...me again...LOL

OK, so now I desperately need some code to copy a range of cells and
paste it into MS Paint to save as a .jpg image for e-mailing purposes. I
know I can use the following to open MS Paint:

shell("mspaint.exe")

But whereto from here for the pasting part...
....and the saving part...
....and the file name specification part...

Anyways, hope someone can help me.

 

[Pecoflyer]

Hi,
don't know if this helps.
But try the following:
Select the range of cells
While pressing the "Shift" key click the Edit menu
Select " Copy Picture"
You know have a picture on your clipboard that you can paste in an
email or where you like.

Hi all...me again...LOL

OK, so now I desperately need some code to copy a range of cells and
paste it into MS Paint to save as a .jpg image for e-mailing purposes. I
know I can use the following to open MS Paint:

shell("mspaint.exe")

But whereto from here for the pasting part...
...and the saving part...
...and the file name specification part...

Anyways, hope someone can help me.

 

[Tim Williams]

http://www.codeforexcelandoutlook.com/blog/2009/04/export-excel-range-to-a-picture-file-redux/

Tim

 

[ARbitOUR]

Hi there.

Thx for the solution!

Unfortunately I seem to have problem using this solution. If I adjust
the code to force saving into .JPG format, the quality seems to be a lot
lower than when I manualy copy the range to MS Paint and saving it as
..JPG.

How can I improve the image quality resulting from using the macro so
that it is the same quality (or better) when it is done manually (both
file sizes are aprox. the same and both are in .jpg format)?

The file size needs to be small enough to avoid delays when e-mailed.
Obviously I wish to avoid saving the file as a 24bit (or even 16bit)
BMP.

Any suggestions?

Thx in advance

 

[ARbitOUR]

Found a solution:





MSPaint = Shell("mspaint.exe", 1)

'Delay until MS Paint is open
Do Until Wait <> 0
DoEvents
Wait = FindWindow("MSPaintApp", "untitled -
Paint")
Loop

Set PriceList = Workbooks.Open(ThisWorkbook.Path &
"\..\Quote Template\HC Price Lists.xlsm",
ignorereadonlyrecommended:=True)
Set QuoteSht = ThisWorkbook.Sheets("Quote")
QuoteSht.Activate
QuoteSht.Unprotect Password:=Workbooks("HC Price
Lists.xlsm").Worksheets("Belgotex").Range("W1")

' Copy range to MS Paint and protect QuoteSht
Range("A1:W67").CopyPicture Appearance:=xlScreen,
Format:=xlPicture
ActiveSheet.Protect Password:=Workbooks("HC Price
Lists.xlsm").Worksheets("Belgotex").Range("W1")
AppActivate MSPaint
SendKeys "^v", True
DoEvents

' Set Save As Parms
FileName = ThisWorkbook.Name

Application.Wait Now + TimeValue("00:00:01")
SendKeys ALT & "F", True ' File Menu
DoEvents
Application.Wait Now + TimeValue("00:00:01")
SendKeys "A", True ' Save As dialog
DoEvents
Application.Wait Now + TimeValue("00:00:01")
SendKeys Left(FileName, Len(FileName) - 1), True
DoEvents
SendKeys "{BACKSPACE 4}", True
DoEvents
SendKeys ".jpg", True ' Set image format
DoEvents
Application.Wait Now + TimeValue("00:00:02")
SendKeys "{TAB}", True ' Select 'save as
type' drop down menu
DoEvents
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{DOWN 2}", True ' Select .jpg file
format
DoEvents
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{ENTER}", True ' Activate
selection
DoEvents
Application.Wait Now + TimeValue("00:00:01")
SendKeys ALT & "S", True ' Save
DoEvents
Application.Wait Now + TimeValue("00:00:03")

'Close MS Paint
SendKeys ALT & "{F4}", True
DoEvents
Application.Wait Now + TimeValue("00:00:01")
Application.Interactive = True
Application.DisplayAlerts = True
Application.WindowState = xlMaximized






YIPPEEEEE!!!!