Not sure how to complete this code

[dan7055]

What I am trying to do is:

1) activate my browser window
2)Take a screenshot of the screen
3)Open Paint and paste in the screenshot, or if paint is already open then just activate paint and paste in the screenshot
4)Save the screenshot to a specific directory with a specific name
5)Delete the contents of paint
6)Activate the broswer again then the activeworkbook.


I do not fully understand the code however from looking on the internet, I have managed to make steps 2, and 3 work. Can somebody perhaps help me out with the rest?

Option Explicit

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

Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12

Sub AltPrintScreen()
    keybd_event VK_MENU, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
    
    
    
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.Run "mspaint"
    Application.Wait Now + TimeValue("00:00:01")

    WshShell.AppActivate "Paint"
    Application.Wait Now + TimeValue("00:00:01")

    WshShell.SendKeys "^(v)"
    Application.Wait Now + TimeValue("00:00:01")
End Sub

Thanks!

 

[YasserKhalil]

This may help you a little in your issue

Private Const CCHDEVICENAME = 32Private Const CCHFORMNAME = 32
Private Const SRCCOPY = &HCC0020


Private Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type


Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare Function EmptyClipboard Lib "user32.dll" () As Long
Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "user32.dll" () As Long
Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long


Declare Function CountClipboardFormats Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CreateIC Lib "GDI32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long


Sub GetPrintScreen()
    'SET SCREEN CAPTURE SIZES HERE
    Call CaptureScreen(0, 0, 1200, 900)
End Sub


Public Sub ScreenToGIF_NewWorkbook()
    Dim wbDest As Workbook, wsDest As Range
    Dim FromType As String, PicHigh As Single
    Dim PicWide As Single, PicWideInch As Single
    Dim PicHighInch As Single, DPI As Long
    Dim PixelsWide As Integer, PixelsHigh As Integer


    Call TOGGLEEVENTS(False)
    Call GetPrintScreen


    If CountClipboardFormats = 0 Then
        MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste"
        GoTo EndOfSub
    End If


    If IsClipboardFormatAvailable(14) <> 0 Then
        FromType = "pic"
    ElseIf IsClipboardFormatAvailable(2) <> 0 Then
        FromType = "bmp"
    Else
        MsgBox "Clipboard does not contain a picture or bitmap to paste.", _
               vbExclamation, "No Picture"
        Exit Sub
    End If


    Application.StatusBar = "Pasting from clipboard ..."


    Set wbDest = ActiveWorkbook
    Set wsDest = Sheet1.Range("G3")
    
    wbDest.Activate
    wsDest.Range("G3").Activate


    On Error Resume Next
        ActiveSheet.Pictures.Paste.Select
    On Error GoTo 0


    If TypeName(Selection) = "OLEObject" Then
        With Selection
            .CopyPicture Appearance:=xlScreen, Format:=xlBitmap
            .Delete
            ActiveSheet.Pictures.Paste.Select
            
            FromType = "ole object"
        End With
    End If


    If TypeName(Selection) = "Picture" Then
        With Selection
            PicWide = .Width
            PicHigh = .Height
            .Delete
        End With
    Else
        If TypeName(Selection) = "ChartObject" Then
            MsgBox "Use Shift > Edit > Copy Picture on charts, not just Copy.", _
                   vbExclamation, "Got a Chart Copy, not a Chart Picture"
        Else
            MsgBox "Excel pasted a '" & TypeName(Selection) & "' instead of a Picture.", _
                   vbExclamation, "Not a Picture"
        End If
        
        ActiveWorkbook.Close SaveChanges:=False
        GoTo EndOfSub
    End If


    With Sheets(1)
        .ChartObjects.Add(.Range("G3").Left, .Range("G3").Top, PicWide, PicHigh).Activate
    End With


    On Error Resume Next
        ActiveChart.Pictures.Paste.Select
    On Error GoTo 0
    
    If TypeName(Selection) = "Picture" Then
        PicWideInch = PicWide / 72
        PicHighInch = PicHigh / 72
        DPI = PixelsPerInch()
        PixelsWide = PicWideInch * DPI
        PixelsHigh = PicHighInch * DPI
    Else
        MsgBox "Clipboard Corrupted, Possibly By Another Task"
    End If


    Application.CutCopyMode = False


EndOfSub:
    Call TOGGLEEVENTS(True)
End Sub


Sub SelectionPic()
    Dim x As Range


    Application.DisplayAlerts = False


    On Error Resume Next
    Set x = Application.InputBox("Please select a range", "Range Selection", Type:=8)


    If Not x Is Nothing Then
        If MsgBox("You Have Selected The Range " & x.Address & " Click OK To Continue Or Cancel", vbOKCancel, ("Confirm Range Selection")) = vbOK Then


            On Error GoTo 0


            x.Select
            x.Copy
            Range("K4").Select
            ActiveSheet.Pictures.Paste.Select
            On Error Resume Next
            ActiveSheet.Shapes.Range(Array("Picture 13")).Select
        Else: Exit Sub
        End If


    End If


    Application.CutCopyMode = False
    Application.DisplayAlerts = True
End Sub


Sub Test()
    Dim chtObj As ChartObject


    ActiveSheet.Pictures.Delete


    For Each chtObj In ActiveSheet.ChartObjects
        chtObj.Delete
    Next chtObj
End Sub


Public Sub TOGGLEEVENTS(blnState As Boolean)
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
End Sub


Public Function PixelsPerInch() As Long
    Dim hdc As Long
    
    hdc = CreateIC("DISPLAY", vbNullString, vbNullString, 0)
    PixelsPerInch = GetDeviceCaps(hdc, 88)
    DeleteDC (hdc)
End Function


Public Sub CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long)
    Dim srcDC As Long, trgDC As Long, BMPHandle As Long, dm As DEVMODE
    
    srcDC = CreateDC("DISPLAY", "", "", dm)
    trgDC = CreateCompatibleDC(srcDC)
    BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height)
    SelectObject trgDC, BMPHandle
    BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY
    OpenClipboard 0&
    EmptyClipboard
    SetClipboardData 2, BMPHandle
    CloseClipboard
    DeleteDC trgDC
    ReleaseDC BMPHandle, srcDC
End Sub


Sub UsedRngPic()
    ActiveSheet.UsedRange.Select
    Selection.Copy
    Range("K4").Select
    ActiveSheet.Pictures.Paste.Select
    
    On Error Resume Next
    ActiveSheet.Shapes.Range(Array("Picture 13")).Select
    Application.CutCopyMode = False
End Sub

 

[dan7055]

What exactly is all that? I noticed it has multiple sub procedures in it?

 

[YasserKhalil]

It captures a screen shot of the screen using this procedure "ScreenToGIF_NewWorkbook"