Take screenshot, rename screenshot based on cell value, save and paste link of saved SS

[iSoleil]

Hi excel masters!


I'm a complete noob when it comes to vba. All the successes that I have had on the personal tasks that I've been doing so far comes mostly from previously raised questions on this site. However, I couldn't find one specifically for what I'm trying to do.


I want to be able to take a screenshot of an active window, name it based on a cell value (B4), save it as a jpg image to a pre-selected folder and lastly, paste the link of that saved screenshot file on the same row, few columns down as the source cell (say, F4)... Then, of course, select the cell one row down from the source cell and do it all again at a press of an activex command button.


I'm basically tracking items as I work on them and want the screenshots to be saved as proof that I entered figures correctly when I handled them.


I have been able to locate the a code for the screencap (thanks to tlowry) from this thread but I can't seem to able to work out the rest.


Your reponses will be highly anticipated. Thanks in advance!
BTW, I'm using excel 2010.

 

[Worf]

Hi

' standard module
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
 bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)


Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal Index As Long) As Long
Declare Function GetSystemMetrics16 Lib "user" Alias "GetSystemMetrics" _
(ByVal nIndex As Integer) As Integer


Private Const KEYEVENTF_KEYUP = &H2     ' key up
Private Const VK_SNAPSHOT = &H2C        ' print screen key
Private Const VK_MENU = &H12            ' alt key
Private Const VK_CONTROL = &H11         ' ctrl key


Sub ScreensCapture(vk)
keybd_event vk, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 1
keybd_event vk, 0, KEYEVENTF_KEYUP, 0
End Sub


Sub Window_Capture_VBA(Optional sTitle = "")
Application.CutCopyMode = False
If sTitle <> "" Then
    AppActivate sTitle
    Application.Wait Now() + TimeValue("00:00:03")
    ScreensCapture VK_MENU
Else
    ScreensCapture VK_CONTROL
End If
Application.Wait Now() + TimeValue("00:00:03")
Sheets("ss").Paste
Selection.Left = 0
Selection.Top = 0
Application.CutCopyMode = False
End Sub

' sheet module
Sub Main()
Dim r As Range
Window_Capture_VBA
Selection.Name = ActiveCell
ExportPicture ActiveCell
Set r = Cells(ActiveCell.Row, ActiveCell.Column + 5)
ActiveSheet.Hyperlinks.Add r, "c:\pub\" & ActiveCell & ".jpg", , , ActiveCell.Value
End Sub


Sub ExportPicture(im$)
Dim ch As String, pic As String, PicWidth&, PicHeight&, n$
Application.ScreenUpdating = 0
n = ActiveSheet.Name
pic = Selection.Name
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:="c:\pub\" & im & ".jpg", FilterName:="jpg"
    .Shapes(ch).Cut
End With
Application.ScreenUpdating = True
End Sub


Private Sub CommandButton2_Click()
Main
End Sub

 

[iSoleil]

Hi Worf! Thanks for replying. Sorry I just got to this now.
Your code works like a charm! It takes me to screenshot + paste to sheet + cut then it gives me an error msg.
It says "Cannot jump to 'ActiveSheet' because it is hidden" for this line:

ActiveSheet.Hyperlinks.Add r, "H:\" & ActiveCell & ".jpg", , , ActiveCell.Value

It's definitely not hidden. It's the active sheet, for crying out loud. I'm not evern sure how to begin looking for a fix.
TT^TT Could you help me again please?

Also, it's possible that there will be a repeat item number on the source cell. How do you enter a code for the next
image under the same item number to say "_2" and so on?

 

[Worf]

o Paste this code on the module corresponding to the sheet where the links are to be created.
o Images will receive an index number.

' sheet module
Sub Main()
Dim r As Range, n$
Window_Capture_VBA
Me.[j1] = "Header"
Me.[p:q].ClearContents
Me.[p1] = "Header"
Me.[p2] = ActiveCell
Me.Range("j:j").AdvancedFilter xlFilterCopy, Me.[p1:p2], Me.[q1], 0
n = ActiveCell & "_" & Me.Range("q" & Rows.Count).End(xlUp).Row - 1
Selection.Name = n
ExportPicture n
Set r = Cells(ActiveCell.Row, ActiveCell.Column + 5)
Me.Hyperlinks.Add r, "c:\pub\" & n & ".jpg", , , n
End Sub

 

[iSoleil]

HI Worf! Your code did the trick! I just adjusted the ranges to suit my needs and it works like a charm! Thanks so much for your help!

 

[iSoleil]

Hi Worf,

I hope you can still see this.

I'm having trouble adding another column for the screenshots. What I need is to be able to click the same command button then if the +5 column is occupied for it to take a new screenshot and place it in +6 column.

The code below does that but it doesn't save as a new image. It replaces the previous one on +5 with a new screenshot with the same file name. How can I make this code work so it runs a search on the Screenshot folder that I have and return it with a new file name if it's a repeat name?

I can also do with saving the screenshot as "activecellname_hh:mm:ss" that the screenshot was taken. I think that'll simplify my request? lol, not sure. Anyway, here's the code I use. Thanks in advance!


Sheet module:

Sub Main()
Dim r As Range, n$
Call lastcellonB
Window_Capture_VBA "Reflection Workspace - [Mortgage Processing Express]"
Me.[v1] = "Header"
Me.[ab:ac].ClearContents
Me.[ab1] = "Header"
Me.[ab2] = ActiveCell
Me.Range("v:v").AdvancedFilter xlFilterCopy, Me.[ab1:ab2], Me.[ac1], 0
n = ActiveCell & "_" & Me.Range("ac" & Rows.Count).End(xlUp).Row - 1
Selection.Name = n
ExportPicture n
If Cells(ActiveCell.Row, ActiveCell.Column + 5) = "" Then
Set r = Cells(ActiveCell.Row, ActiveCell.Column + 5)
Me.Hyperlinks.Add r, "H:\Support Tracker\Screenshots\" & n & ".jpg", , , n
Else
    Set r = Cells(ActiveCell.Row, ActiveCell.Column + 6)
    Me.Hyperlinks.Add r, "H:\Support Tracker\Screenshots\" & n & ".jpg", , , n
    End If
End Sub

 

[Worf]

Hi

I'm going offline now but will work on it as soon as possible...

 

[Worf]

Hi

The code below gives a unique name to the screenshot and places the link after the last used column on that row:

Sub Main()
Dim s$
Window_Capture_VBA
s = ActiveCell & Replace(Replace(Date & "_" & Time, "/", "_"), ":", "_")
Selection.Name = s
ExportPicture s
Me.Hyperlinks.Add Cells(ActiveCell.Row, Cells(ActiveCell.Row, _
Columns.Count).End(xlToLeft).Column + 1), "c:\pub\" & s & ".jpg", , , s
End Sub

 

[iSoleil]

Thanks Worf! This is what I needed! You rock! \m/

Hi

The code below gives a unique name to the screenshot and places the link after the last used column on that row:

Sub Main()
Dim s$
Window_Capture_VBA
s = ActiveCell & Replace(Replace(Date & "_" & Time, "/", "_"), ":", "_")
Selection.Name = s
ExportPicture s
Me.Hyperlinks.Add Cells(ActiveCell.Row, Cells(ActiveCell.Row, _
Columns.Count).End(xlToLeft).Column + 1), "c:\pub\" & s & ".jpg", , , s
End Sub