Feedback by UserVoice

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


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
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
Sign in with: Facebook Google
Signed in as (Sign out)
  • 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