Feedback by UserVoice

How can we improve Excel for Windows (Desktop Application)?

savepicture

Port vba .SavePicture from Word and VS to Excel as the present exporting/saving of pieces of the spreadsheet including any artwork is absolutely cumbersome.

Sample code

Dim pic As IPictureDisp

Set pic = myForm.Image1.Picture

stdole.SavePicture pic, "C:\myfile.jpg"

1 vote
Sign in
(thinking…)
Sign in with: Facebook Google
Signed in as (Sign out)

We’ll send you updates on this idea

SekeRob shared this idea  ·   ·  Flag idea as inappropriate…  ·  Admin →

1 comment

Sign in
(thinking…)
Sign in with: Facebook Google
Signed in as (Sign out)
Submitting...
  • SekeRob commented  ·   ·  Flag as inappropriate

    This is how a working example looks at present in Excel 365 to get any piece of the screen/object to an an image file:

    [code]Option Explicit
    Public Const BaseP As String = "WbkLoc" 'Dir where file is stored, in BaseP constant
    Private Sub ExportSummary() 'chg 30.06.2017, see if Specials subfolder exists, else create.
    '
    Dim fso As Object, area As Object 'add 18.06.2017
    Set fso = CreateObject("Scripting.FileSystemObject") 'add 18.06.2017
    If Len(Dir(Range(BaseP), vbDirectory)) = 0 Then 'add 18.06.2017
    fso.CreateFolder Range(BaseP) 'add 18.06.2017
    End If 'add 18.06.2017
    Set area = Range("ActiveSparks") 'sALL.Shapes("ActiveSparks1") 'disab 30.06.2017
    area.CopyPicture xlScreen, xlBitmap 'disab 30.06.2017
    Call OpenPaint(Range(BaseP) & "ActiveData.Png")
    Run "TimeStamp", "Export" 'inserts execution time below export summary button.

    End Sub
    Public Function OpenPaint(strFile$) 'ver 18.06.2017 need to figure out how to catch error if file does not exist yet

    10 Dim paintID$, WshShell As Object: Set WshShell = CreateObject("WScript.Shell")
    20 Dim ObjFso As Object, CheckExists As Boolean
    30 Set ObjFso = CreateObject("Scripting.FileSystemObject")
    40 CheckExists = ObjFso.FileExists(strFile)
    50 Select Case CheckExists
    Case True
    60 paintID = Shell("mspaint.exe " & Chr(34) & strFile & Chr(34), vbNormalFocus) 'open app through Shell call, _
    concatenation of app + path in quotes (needed due spaces in path), use only 1 or 9, newly opened, existing opened.
    70 Case False
    80 paintID = Shell("mspaint.exe ", vbNormalFocus) 'code 1
    90 End Select
    100 Application.Wait Now + TimeValue("00:00:02") ' VBA does all timing in whole seconds
    110 With WshShell 'Call Windows Scripting and pass keystrokes per below, with delays
    120 .SendKeys "^(v)" 'paste
    130 Application.Wait Now + TimeValue("00:00:01") ' VBA does all timing in whole seconds
    140 Select Case CheckExists
    Case True
    150 .SendKeys "^(s)" 'save file - needs to cater for language of interface as set by user
    160 Case False
    170 .SendKeys "%Fav" 'save file as - needs to cater for language of interface as set by user
    180 .SendKeys strFile 'paste filename
    190 .SendKeys "%S"
    200 End Select
    210 Application.Wait Second(Now) + 0 'A different way to set a wait-state, DoEvents would do here to.
    220 .SendKeys "%Fx" 'open file menu, combined %(F) and eXit into %Fx, no waits needed - 18-9-2016
    230 End With 'WshShell

    End Function[/code]

Feedback and Knowledge Base