VBA For Screenshot...With A Twist

VinceF

VinceF

Board Regular
Joined
Sep 22, 2007
Messages
186
Office Version
  1. 2016
Platform
  1. Windows
Hello Experts,
Is it possible to have a command button that when selected would open 2 tabs/pages (1 at a time I'm sure), take a screen shot and then save it to a folder?
It would open up the "MAIN" page take a screen shot and save it as the file name (Indianwood Quota.xlsm) in a .jpeg format to C:Indianwood Quota\Screenshots and then open up the 2nd tab/page called "VinE Cup" and do the same thing...screenshot/file save?

Ideally if I could put it inside of this existing VBA that I use to save the file after each round.

Sub SaveWithTodaysDate()
ActiveWorkbook.SaveAs ("C:\Golf\Indianwood Quota\Results\" & ThisWorkbook.Sheets("Main").Range("AK2").Value & ThisWorkbook.Sheets("Main").Range("AH3").Value & ThisWorkbook.Sheets("Main").Range("AJ3").Value & ".xlsm")
Range("AA3") = Range("AA3") + 1

End Sub


Thank You
VinceF
Office 2016
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
VinceF said:
Hello Experts,
Is it possible to have a command button that when selected would open 2 tabs/pages (1 at a time I'm sure), take a screen shot and then save it to a folder?
It would open up the "MAIN" page take a screen shot and save it as the file name (Indianwood Quota.xlsm) in a .jpeg format to C:Indianwood Quota\Screenshots and then open up the 2nd tab/page called "VinE Cup" and do the same thing...screenshot/file save?

Ideally if I could put it inside of this existing VBA that I use to save the file after each round.

Sub SaveWithTodaysDate()
ActiveWorkbook.SaveAs ("C:\Golf\Indianwood Quota\Results\" & ThisWorkbook.Sheets("Main").Range("AK2").Value & ThisWorkbook.Sheets("Main").Range("AH3").Value & ThisWorkbook.Sheets("Main").Range("AJ3").Value & ".xlsm")
Range("AA3") = Range("AA3") + 1

End Sub


Thank You
VinceF
Office 2016
Click to expand...
When you say screen shot do you mean a particular range or everything on the worksheet?

What naming convention do you need for these jpeg files?
 
Upvote 0
Thanks for your interest...
The screen shot would be of the whole sheet or screen. As for the 2nd question I'm not sure what "convention" is but I'm assuming you're asking what name to save these files with...Ideally it would be saved with the tab/pages names, first would be "main", 2nd would be "VinE Cup"
 
Upvote 0
VinceF said:
Thanks for your interest...
The screen shot would be of the whole sheet or screen. As for the 2nd question I'm not sure what "convention" is but I'm assuming you're asking what name to save these files with...Ideally it would be saved with the tab/pages names, first would be "main", 2nd would be "VinE Cup"
Click to expand...
I have written this but I had some trouble on large worksheets.

I don't know how large yours are,

This code is an example of how to call the subSaveRangeImageAsJPEGFile procedure.
VBA Code: 
Private Sub Main()

    ActiveWorkbook.Save
   
    Call subSaveRangeImageAsJPEGFile(Worksheets("Main"))
   
    Call subSaveRangeImageAsJPEGFile(Worksheets("VinE Cup"))

    MsgBox "Finished Creating JPEG Files", vbOKOnly, "Confirmation"

End Sub

VBA Code: 
Public Sub subSaveRangeImageAsJPEGFile(Ws As Worksheet)
Dim objChart As ChartObject
Dim WsChart As Worksheet
Dim rngToImage As Range
  
  Set rngToImage = Ws.UsedRange
  
  On Error Resume Next
  Application.DisplayAlerts = False
  Worksheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = Format(Now(), "DDMMYYYYHHMMSS")
  Set WsChart = ActiveSheet
  Application.DisplayAlerts = True
  On Error GoTo 0

  On Error Resume Next
  Kill (ActiveWorkbook.Path & "\" & Ws.Name & ".jpg")
  On Error GoTo 0
  
  Set objChart = WsChart.ChartObjects.Add(Left:=10, Top:=10, Width:=rngToImage.Width * 2, Height:=rngToImage.Height * 2)
    
  rngToImage.CopyPicture
  
  WsChart.Activate
  
  objChart.Select
    
  With ActiveChart
    .Paste
    .Export Filename:=ActiveWorkbook.Path & "\" & Ws.Name & ".jpg", FilterName:="JPEG"
  End With
  
  Application.Wait (Now + TimeValue("0:00:01"))
  
  objChart.Delete
  
  Ws.Activate
  
  On Error Resume Next
  Application.DisplayAlerts = False
  WsChart.Delete
  Application.DisplayAlerts = True
  On Error GoTo 0
  
End Sub
 
Upvote 0
HighAndWilder said:
I have written this but I had some trouble on large worksheets.

I don't know how large yours are,

This code is an example of how to call the subSaveRangeImageAsJPEGFile procedure.
VBA Code: 
Private Sub Main()

    ActiveWorkbook.Save
  
    Call subSaveRangeImageAsJPEGFile(Worksheets("Main"))
  
    Call subSaveRangeImageAsJPEGFile(Worksheets("VinE Cup"))

    MsgBox "Finished Creating JPEG Files", vbOKOnly, "Confirmation"

End Sub

VBA Code: 
Public Sub subSaveRangeImageAsJPEGFile(Ws As Worksheet)
Dim objChart As ChartObject
Dim WsChart As Worksheet
Dim rngToImage As Range
 
  Set rngToImage = Ws.UsedRange
 
  On Error Resume Next
  Application.DisplayAlerts = False
  Worksheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = Format(Now(), "DDMMYYYYHHMMSS")
  Set WsChart = ActiveSheet
  Application.DisplayAlerts = True
  On Error GoTo 0

  On Error Resume Next
  Kill (ActiveWorkbook.Path & "\" & Ws.Name & ".jpg")
  On Error GoTo 0
 
  Set objChart = WsChart.ChartObjects.Add(Left:=10, Top:=10, Width:=rngToImage.Width * 2, Height:=rngToImage.Height * 2)
   
  rngToImage.CopyPicture
 
  WsChart.Activate
 
  objChart.Select
   
  With ActiveChart
    .Paste
    .Export Filename:=ActiveWorkbook.Path & "\" & Ws.Name & ".jpg", FilterName:="JPEG"
  End With
 
  Application.Wait (Now + TimeValue("0:00:01"))
 
  objChart.Delete
 
  Ws.Activate
 
  On Error Resume Next
  Application.DisplayAlerts = False
  WsChart.Delete
  Application.DisplayAlerts = True
  On Error GoTo 0
 
End Sub
Click to expand...
I very much appreciate your time and effort. I tried to implement it into the spreadsheet but it's over my limited abilities to do so.

Vince F
 
Upvote 0
VinceF said:
I very much appreciate your time and effort. I tried to implement it into the spreadsheet but it's over my limited abilities to do so.

Vince F
Click to expand...
OK.

On step at a time.

Are you able to create a Command Button (Active X Control) on a worksheet with the name of cmdScreenShot and edit the code behind it to give you the following?

VBA Code: 
Private Sub cmdScreenShot_Click()

  MsgBox "This Command Button Works", vbOKOnly, "Confirmation"

End Sub

When you click on the button you will get this message as in the image attached.
 

Attachments

  • button.jpg
    button.jpg
    9 KB · Views: 1
Upvote 0
HighAndWilder said:
OK.

On step at a time.

Are you able to create a Command Button (Active X Control) on a worksheet with the name of cmdScreenShot and edit the code behind it to give you the following?

VBA Code: 
Private Sub cmdScreenShot_Click()

  MsgBox "This Command Button Works", vbOKOnly, "Confirmation"

End Sub

When you click on the button you will get this message as in the image attached.
Click to expand...
Private Sub CommandButton1_Click()

End Sub

Private Sub RESET_Click()

Dim warning
warning = MsgBox(Range("A1").Value & " << CAUTION >>THIS WILL REST THE ENTIRE SHEET. SELECT OK TO CONTINUE OR SELECT CANCEL TO CONTINUE WITHOUT RESETTING", vbOKCancel, "QUOTA #1 #2 #3 RESET & SAVE / SKINS #1 RESET & SAVE")
If warning = vbCancel Then Exit Sub

On Error Resume Next

Sheets("main").Range("B11:H50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("C5:C8").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("O11:W50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("Y11:AG50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("D11:D50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("D3:F3").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("g11:H50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("L7").ClearContents
Sheets("main").Range("M11:M50").ClearContents
Sheets("main").Range("N3:O3").ClearContents
Sheets("main").Range("B2").Value = "SELECT COURSE"
Sheets("main").Range("B3").Value = "STR ADJ"
Sheets("main").Range("C3").Value = "SELECT GAME"
Sheets("main").Range("L5").Value = "STAFF"
Sheets("main").Range("N3").Value = "SELECT TEE"

MsgBox "THE FORM HAS BEEN RESET."
HighAndWilder said:
OK.

On step at a time.

Are you able to create a Command Button (Active X Control) on a worksheet with the name of cmdScreenShot and edit the code behind it to give you the following?

VBA Code: 
Private Sub cmdScreenShot_Click()

  MsgBox "This Command Button Works", vbOKOnly, "Confirmation"

End Sub

When you click on the button you will get this message as in the image attached.
Click to expand...
Thanks so much for taking the extra time/effort.
Yes I am able and I have made the active x button and it's working.
 
Upvote 0
VinceF said:
Private Sub CommandButton1_Click()

End Sub

Private Sub RESET_Click()

Dim warning
warning = MsgBox(Range("A1").Value & " << CAUTION >>THIS WILL REST THE ENTIRE SHEET. SELECT OK TO CONTINUE OR SELECT CANCEL TO CONTINUE WITHOUT RESETTING", vbOKCancel, "QUOTA #1 #2 #3 RESET & SAVE / SKINS #1 RESET & SAVE")
If warning = vbCancel Then Exit Sub

On Error Resume Next

Sheets("main").Range("B11:H50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("C5:C8").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("O11:W50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("Y11:AG50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("D11:D50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("D3:F3").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("g11:H50").SpecialCells(xlCellTypeConstants).ClearContents
Sheets("main").Range("L7").ClearContents
Sheets("main").Range("M11:M50").ClearContents
Sheets("main").Range("N3:O3").ClearContents
Sheets("main").Range("B2").Value = "SELECT COURSE"
Sheets("main").Range("B3").Value = "STR ADJ"
Sheets("main").Range("C3").Value = "SELECT GAME"
Sheets("main").Range("L5").Value = "STAFF"
Sheets("main").Range("N3").Value = "SELECT TEE"

MsgBox "THE FORM HAS BEEN RESET."

Thanks so much for taking the extra time/effort.
Yes I am able and I have made the active x button and it's working.
Click to expand...

So now just replace the cmdScreenShot_Click procedure with this code.

The cmdScreenShot_Click procedure will be replaced with the new code below.

Go to the worksheet and press the button.

The screen images will be in the same folder as the workbook.

I notice that you have other code in there, don't overwrite it.

VBA Code: 
Private Sub cmdScreenShot_Click()

  Call subSaveRangeImageAsJPEGFile(Worksheets("Main"))
   
  Call subSaveRangeImageAsJPEGFile(Worksheets("VinE Cup"))

  MsgBox "Finished Creating JPEG Files", vbOKOnly, "Confirmation"

End Sub

Private Sub subSaveRangeImageAsJPEGFile(Ws As Worksheet)
Dim objChart As ChartObject
Dim WsChart As Worksheet
Dim rngToImage As Range
  
  Set rngToImage = Ws.UsedRange
  
  On Error Resume Next
  Application.DisplayAlerts = False
  Set WsChart = Worksheets.Add(after:=Sheets(Sheets.Count))
  ActiveSheet.Name = Format(Now(), "DDMMYYYYHHMMSS")
  Application.DisplayAlerts = True
  On Error GoTo 0

  On Error Resume Next
  Kill (ActiveWorkbook.Path & "\" & Ws.Name & ".jpg")
  On Error GoTo 0
  
  Set objChart = WsChart.ChartObjects.Add(Left:=10, Top:=10, Width:=rngToImage.Width * 2, Height:=rngToImage.Height * 2)
    
  rngToImage.CopyPicture
  
  WsChart.Activate
  
  objChart.Select
    
  With ActiveChart
    .Paste
    .Export Filename:=ActiveWorkbook.Path & "\" & Ws.Name & ".jpg", FilterName:="JPEG"
  End With
  
  Application.Wait (Now + TimeValue("0:00:01"))
  
  objChart.Delete
  
  Ws.Activate
  
  On Error Resume Next
  Application.DisplayAlerts = False
  WsChart.Delete
  Application.DisplayAlerts = True
  On Error GoTo 0
  
End Sub
 
Upvote 0
Can you change this to fit your need?
If not, I'll should have some time later today. I'll check back.
Code: 
Sub Save_Visible_Part_Of_Sheet()
Dim sPath As String
Dim rRng As Object, sht As Object
Dim i As Long
For i = 1 To 2
Set sht = ThisWorkbook.Worksheets(i)
sPath = ThisWorkbook.Path & "\" & Sheets(i).Name & ".jpg"
Set rRng = sht.Range(Application.ActiveWindow.VisibleRange.Address)
rRng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
With rRng.Parent.ChartObjects.Add(10, 10, 100, 100)
    .ShapeRange.Line.Visible = msoFalse
    .Height = rRng.Height
    .Width = rRng.Width
    .Chart.Paste
    .Chart.Export Filename:=sPath, Filtername:="JPG"
    .Delete
End With
Next i
End Sub
 
Upvote 0
If you mean like a PrintScreen Screen Shot?
www.mrexcel.com

Macro to take screenshot then save to desktop without user intervention

Not sure if this is even possible but I am looking for a vba script that will allow me to screenshot my screen, save it to a specific path and use a specific filename format without user intervention. It's like when I click the button it will automatically save it to my desired path without...
www.mrexcel.com www.mrexcel.com
 
Upvote 0
You must log in or register to reply here.

Similar threads

VinceF
  • Solved
Combine 2 VBA Script's to 1 Command Button
Replies
3
Views
288
Candyman8019
C
VinceF
  • Solved
Saveas Exit & Close Without Prompts
2
Replies
14
Views
1K
Peter_SSs
Peter_SSs
VinceF
  • Solved
Code to Disregard VBA or to Execute if Condition Met
Replies
3
Views
231
Alex Blakenburg
A
J
  • Question Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
895
Peter_SSs
Peter_SSs
VinceF
  • Question Question
VBA To Copy & Paste Value
Replies
0
Views
351
VinceF
VinceF

Forum statistics

Threads
1,222,569
Messages
6,166,837
Members
452,077
Latest member
hufflefry

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top