Macro saving screenshot using filename with a wildcard

becklog

New Member
Joined
Dec 26, 2016
Messages
38
Hi,

I have this macro (see below) that allows me to take screenshot and save it to a specific path with a specific filename. For the path, it is user dependent. For the filename, it is reference to the active cell selected during the screenshot. Before I am only required to sceenshot 1 part of the transaction and save it using the ticket number as the file name. Now, we have to screenshot at least 4-6 parts of the transaction hence this post. Is there a way to update this macro that will allow me to save screenshots using 1 filename then just add "(1)" at the end of the name if more screenshot is required? To make it clearer, If the active cell has "TICKETA" then I do a screenshot, it will save the file as TICKETA. the next screenshot will be named as TICKETA(1), the next will be TICKETA(2), so on and so forth.
Note: The "(1)" is not really required, any will do.

Sub Main()
Dim r As Range
Dim Path As String
Path = Range("A1")
Window_Capture_VBA
Selection.Name = ActiveCell
ExportPicture ActiveCell
Set r = Cells(ActiveCell.Row, ActiveCell.Column + 5)
ActiveSheet.Hyperlinks.Add r, Path & ActiveCell & ".jpg", , , ActiveCell.Value
End Sub
_________________________________________________________________________________________________________
Sub ExportPicture(im$)
Dim ch As String, pic As String, PicWidth&, PicHeight&, n$
Dim Path As String
Application.ScreenUpdating = 0
n = ActiveSheet.Name
pic = Selection.Name
Path = Range("A1")
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=n
Selection.Border.LineStyle = 0
ch = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With ActiveSheet
With .Shapes(ch)
.Width = PicWidth
.Height = PicHeight
End With
.Shapes(pic).Copy
.Shapes(pic).Delete
ActiveChart.ChartArea.Select
ActiveChart.Paste
.ChartObjects(1).Chart.Export Filename:=Path & im & ".jpg", FilterName:="jpg"
.Shapes(ch).Cut
End With
Application.ScreenUpdating = True
MsgBox "Image created and saved."
End Sub
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Forum statistics

Threads
1,224,819
Messages
6,181,153
Members
453,021
Latest member
Justyna P

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