SCREEN CAPTURE AKTIFITAS PEMAKAI KOMPUTER

Asal-usul judul “SCREEN CAPTURE AKTIFITAS PEMAKAI KOMPUTER” adalah berkat suatu kejadian sering beratnya internet kantor. Saat internet terasa berat, saya langsung saja masuk ke winbox dan mencari tahu komputer siapa yang pemakaian internetnya tinggi. Dan akhirnya ketahuan sumber penyebabnya. Namun yang kelihatan hanyalah source ip address,destination ip address yang diakses dan besarnya paket yang diambil.

Dari kejadian itu saya punya inisiatif untuk membuat sebuah aplikasi yang bisa merekam aktifitas komputer dalam hal ini meng-capture (print screen) aktifitas pemakai komputer dan menyimpan file-nya lalu kemudian mengirimkan hasil capture tersebut ke alamat email saya (kirim email dalam periode waktu tertentu agar tidak terlalu membebani bandwidth internet).

Aplikasi saya buat menggunakan Visual Basic 6.0 dan EASendMailObj.dll untuk kirim email.

Download EASendMail disini.

silahkan install dulu EASendMail-nya.

Lalu di jendela visual basic ikuti langkah di bawah ini.

1. Di dalam Form1 masukan 3 tools yaitu 1 picturebox dan 2 buah timer. Silahkan setting Form seperti gambar di bawah ini 
   
2. Tambahkan Module1 pada project (Klik kanan pada project > Add > Module)
• Module1 digunakan untuk script capture screen windows, silahkan kopi script ini dan taruh di dalam Module1
Option Explicit Option Base 0 Private Type PALETTEENTRY peRed As Byte peGreen As Byte peBlue As Byte peFlags As Byte End Type Private Type LOGPALETTE palVersion As Integer palNumEntries As Integer palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type Private Const RASTERCAPS As Long = 38 Private Const RC_PALETTE As Long = &H100 Private Const SIZEPALETTE As Long = 104 Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _ ByVal hdc As Long, ByVal nWidth As Long, _ ByVal nHeight As Long) As Long ' Retrieves device-specific information about a specified device. Private Declare Function GetDeviceCaps Lib "gdi32" ( _ ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long ' Retrieves a range of palette entries from the system palette ' associated with the specified DC. Private Declare Function GetSystemPaletteEntries Lib "gdi32" ( _ ByVal hdc As Long, ByVal wStartIndex As Long, _ ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) _ As Long ' Creates a memory DC compatible with the specified device. Private Declare Function CreateCompatibleDC Lib "gdi32" ( _ ByVal hdc As Long) As Long ' Creates a logical color palette. Private Declare Function CreatePalette Lib "gdi32" ( _ lpLogPalette As LOGPALETTE) As Long ' Selects the specified logical palette into a DC. Private Declare Function SelectPalette Lib "gdi32" ( _ ByVal hdc As Long, ByVal hPalette As Long, _ ByVal bForceBackground As Long) As Long ' Maps palette entries from the current logical ' palette to the system palette. Private Declare Function RealizePalette Lib "gdi32" ( _ ByVal hdc As Long) As Long ' Selects an object into the specified DC. The new ' object replaces the previous object of the same type. ' Returned is the handle of the replaced object. Private Declare Function SelectObject Lib "gdi32" ( _ ByVal hdc As Long, ByVal hObject As Long) As Long ' Performs a bit-block transfer of color data corresponding to ' a rectangle of pixels from the source DC into a destination DC. Private Declare Function BitBlt Lib "gdi32" ( _ ByVal hDCDest As Long, ByVal XDest As Long, _ ByVal YDest As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal hDCSrc As Long, _ ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) _ As Long ' Retrieves the DC for the entire window, including title bar, ' menus, and scroll bars. A window DC permits painting anywhere ' in a window, because the origin of the DC is the upper-left ' corner of the window instead of the client area. Private Declare Function GetWindowDC Lib "USER32" ( _ ByVal hWnd As Long) As Long ' Retrieves a handle to a display DC for the Client area of ' a specified window or for the entire screen. You can use ' the returned handle in subsequent GDI functions to draw in ' the DC. Private Declare Function GetDC Lib "USER32" ( _ ByVal hWnd As Long) As Long ' Releases a DC, freeing it for use by other applications. ' The effect of the ReleaseDC function depends on the type ' of DC. It frees only common and window DCs. It has no ' effect on class or private DCs. Private Declare Function ReleaseDC Lib "USER32" ( _ ByVal hWnd As Long, ByVal hdc As Long) As Long ' Deletes the specified DC. Private Declare Function DeleteDC Lib "gdi32" ( _ ByVal hdc As Long) As Long ' Retrieves the dimensions of the bounding rectangle of the ' specified window. The dimensions are given in screen ' coordinates that are relative to the upper-left corner ' of the screen. Private Declare Function GetWindowRect Lib "USER32" ( _ ByVal hWnd As Long, lpRect As RECT) As Long ' Returns a handle to the Desktop window. The desktop ' window covers the entire screen and is the area on top ' of which all icons and other windows are painted. Private Declare Function GetDesktopWindow Lib "USER32" () As Long Private Declare Function GetForegroundWindow Lib "USER32" () As Long Private Declare Function OleCreatePictureIndirect _ Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _ ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Public Function CreateBitmapPicture(ByVal hBmp As Long, _ ByVal hPal As Long) As Picture Dim r As Long Dim Pic As PicBmp ' ' IPicture requires a reference to "Standard OLE Types" ' Dim IPic As IPicture Dim IID_IDispatch As GUID ' ' Fill in with IDispatch Interface ID ' With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With ' ' Fill Pic with the necessary parts. ' With Pic .Size = Len(Pic) ' Length of structure .Type = vbPicTypeBitmap ' Type of Picture (bitmap) .hBmp = hBmp ' Handle to bitmap .hPal = hPal ' Handle to palette (may be null) End With ' ' Create the Picture object. r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic) ' ' Return the new Picture object. ' Set CreateBitmapPicture = IPic End Function Public Function CaptureWindow(ByVal hWndSrc As Long, _ ByVal bClient As Boolean, ByVal LeftSrc As Long, _ ByVal TopSrc As Long, ByVal WidthSrc As Long, _ ByVal HeightSrc As Long) As Picture Dim hDCMemory As Long Dim hBmp As Long Dim hBmpPrev As Long Dim r As Long Dim hDCSrc As Long Dim hPal As Long Dim hPalPrev As Long Dim RasterCapsScrn As Long Dim HasPaletteScrn As Long Dim PaletteSizeScrn As Long Dim LogPal As LOGPALETTE ' ' Get the proper Device Context (DC) depending on the value of bClient. ' If bClient Then hDCSrc = GetDC(hWndSrc) 'Get DC for Client area. Else hDCSrc = GetWindowDC(hWndSrc) 'Get DC for entire window. End If ' ' Create a memory DC for the copy process. ' hDCMemory = CreateCompatibleDC(hDCSrc) ' ' Create a bitmap and place it in the memory DC. ' hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc) hBmpPrev = SelectObject(hDCMemory, hBmp) ' ' Get the screen properties. ' RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) 'Raster capabilities HasPaletteScrn = RasterCapsScrn And RC_PALETTE 'Palette support PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) 'Palette size ' ' If the screen has a palette make a copy and realize it. ' If HasPaletteScrn And (PaletteSizeScrn = 256) Then ' ' Create a copy of the system palette. ' LogPal.palVersion = &H300 LogPal.palNumEntries = 256 r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0)) hPal = CreatePalette(LogPal) ' ' Select the new palette into the memory DC and realize it. ' hPalPrev = SelectPalette(hDCMemory, hPal, 0) r = RealizePalette(hDCMemory) End If ' ' Copy the on-screen image into the memory DC. ' r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _ LeftSrc, TopSrc, vbSrcCopy) ' ' Remove the new copy of the on-screen image. ' hBmp = SelectObject(hDCMemory, hBmpPrev) ' ' If the screen has a palette get back the ' palette that was selected in previously. ' If HasPaletteScrn And (PaletteSizeScrn = 256) Then hPal = SelectPalette(hDCMemory, hPalPrev, 0) End If ' ' Release the DC resources back to the system. ' r = DeleteDC(hDCMemory) r = ReleaseDC(hWndSrc, hDCSrc) ' ' Create a picture object from the bitmap ' and palette handles. ' Set CaptureWindow = CreateBitmapPicture(hBmp, hPal) End Function Public Function CaptureScreen() As Picture Dim hWndScreen As Long ' ' Get a handle to the desktop window. hWndScreen = GetDesktopWindow() ' ' Capture the entire desktop. ' With Screen Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _ .Width \ .TwipsPerPixelX, .Height \ .TwipsPerPixelY) End With End Function

3. Tambahkan Module2 pada project (Klik kanan pada project > Add > Module)
• Module2 digunakan untuk menyimpan capture ke file jpg dengan kemampuan pengaturen pixcel agar ukuran file tidak terlalu besar, silahkan kopi script ini dan taruh di dalam Module2
'Attribute VB_Name = "ModSaveAsImage" Option Explicit '/////////////////////////////////////////////////// '// SaveImageAs - Save hDC to Bitmap or Jpeg file // '// Ed Wilk/Edgemeal - last updated Feb.06,2010 // '/////////////////////////////////////////////////// 'calling SaveImageAs: 'SaveImageAs "c:\mypicture.jpg", Picture1.hdc, Picture1.Width / Screen.TwipsPerPixelX, Picture1.Height / Screen.TwipsPerPixelY, 75) Private Const BI_RGB As Long = 0 Private Const DIB_RGB_COLORS As Long = 0 Private Type BitmapFileHeader bfType As Integer bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Private Type BitmapInfoHeader biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biDataSize As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Private Type BITMAPINFO bmiHeader As BitmapInfoHeader bmiColors As RGBQUAD End Type Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Private Declare Function BitBlt Lib "gdi32" (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 ' gdi+ Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End Type Private Type EncoderParameter GUID As GUID NumberOfValues As Long Type As Long Value As Long End Type Private Type EncoderParameters Count As Long Parameter As EncoderParameter End Type Private Declare Function GdiplusStartup Lib "GDIPlus" ( _ token As Long, _ inputbuf As GdiplusStartupInput, _ Optional ByVal outputbuf As Long = 0) As Long Private Declare Function GdiplusShutdown Lib "GDIPlus" ( _ ByVal token As Long) As Long Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" ( _ ByVal hbm As Long, _ ByVal hPal As Long, _ Bitmap As Long) As Long Private Declare Function GdipDisposeImage Lib "GDIPlus" ( _ ByVal Image As Long) As Long Private Declare Function GdipSaveImageToFile Lib "GDIPlus" ( _ ByVal Image As Long, _ ByVal filename As Long, _ clsidEncoder As GUID, _ encoderParams As Any) As Long Private Declare Function CLSIDFromString Lib "ole32" ( _ ByVal str As Long, _ id As GUID) As Long Public Sub SaveImageAs(ByVal sFileName As String, ByVal Source_hDC As Long, ByVal Width As Long, ByVal Height As Long, Optional ByVal Quality As Long = 80) Dim sFileExt As String Dim myDIB As Long, myDC As Long, fNum As Long Dim bi24BitInfo As BITMAPINFO Dim fileheader As BitmapFileHeader Dim bitmapData() As Byte ' gdi Dim tSI As GdiplusStartupInput Dim lRes As Long, lGDIP As Long, lBitmap As Long Dim tJpgEncoder As GUID Dim tParams As EncoderParameters ' source hDC to DIB With bi24BitInfo.bmiHeader .biBitCount = 24 .biCompression = BI_RGB .biPlanes = 1 .biSize = Len(bi24BitInfo.bmiHeader) .biWidth = Width .biHeight = Height .biDataSize = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight ReDim bitmapData(0 To .biDataSize - 1) End With myDC = CreateCompatibleDC(0) myDIB = CreateDIBSection(myDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&) SelectObject myDC, myDIB BitBlt myDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, Source_hDC, 0, 0, vbSrcCopy Call GetDIBits(myDC, myDIB, 0, bi24BitInfo.bmiHeader.biHeight, bitmapData(0), bi24BitInfo, DIB_RGB_COLORS) ' get file extension of filename to save as lower case. sFileExt = LCase$(GetFileExt(sFileName)) ' Save image to file.... Select Case sFileExt Case ".bmp" ' save as bmp.... With fileheader .bfType = &H4D42 .bfOffBits = Len(fileheader) + Len(bi24BitInfo.bmiHeader) .bfSize = bi24BitInfo.bmiHeader.biDataSize + .bfOffBits End With fNum = FreeFile On Error GoTo BadFileName Open sFileName For Output As fNum Close fNum Open sFileName For Binary As fNum Put fNum, , fileheader Put fNum, , bi24BitInfo.bmiHeader Put fNum, , bitmapData() Close fNum Case ".jpg", ".png" tSI.GdiplusVersion = 1 ' Initialize GDI+ lRes = GdiplusStartup(lGDIP, tSI) If lRes = 0 Then lRes = GdipCreateBitmapFromHBITMAP(myDIB, 0, lBitmap) ' Create the GDI+ bitmap from the image handle If lRes = 0 Then If sFileExt = ".jpg" Then ' JPG CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder ' Initialize the encoder parameters tParams.Count = 1 With tParams.Parameter ' jpeg Quality CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID .NumberOfValues = 1 .Type = 4 .Value = VarPtr(Quality) End With ElseIf sFileExt = ".png" Then ' PNG CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder End If ' Save the image lRes = GdipSaveImageToFile(lBitmap, StrPtr(sFileName), tJpgEncoder, tParams) ' Destroy the bitmap GdipDisposeImage lBitmap End If ' Shutdown GDI+ GdiplusShutdown lGDIP End If If lRes Then Err.Raise 5, , "Can not save image(GDI+ Error).:" & lRes End If End Select Fini: DeleteObject myDIB DeleteDC myDC Exit Sub BadFileName: Close fNum Err.Raise 5, , "Can not save BMP image.:" & lRes Resume Fini End Sub Private Function GetFileExt(sFile As String) As String ' example" returns ".exe" Dim i As Integer i = InStrRev(sFile, ".") If i Then GetFileExt = Mid$(sFile, i) Else GetFileExt = sFile ' if not found then just return the whole string End If End Function

4. Tambahkan Module3 pada project (Klik kanan pada project >Add > Module)
• Copy script berikut ke module3
Private Declare Function apiGetComputerName Lib "kernel32" Alias _ "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long Function fOSMachineName() As String Dim lngLen As Long, lngX As Long Dim strCompName As String lngLen = 16 strCompName = String$(lngLen, 0) lngX = apiGetComputerName(strCompName, lngLen) If lngX <> 0 Then fOSMachineName = Left$(strCompName, lngLen) Else fOSMachineName = """" End If End Function
5. Kembali ke Form1
• Aturlah property pada control timer, dan picturebox sebagai berikut ini :



Kontrol	Property	Value
Timer1	Enabled	True
	Interval	1000
Timer2	Enabled	True
	Interval	100
Picture1	AutoRedraw	True

6. Buat text file manifest di dalam satu folder dengan project, penamaan file manifest mengikuti nama file exe hasil compile aplikasi (misal hasil compile adalah svchost.exe maka bikinlah file svchost.exe.manifest). Buka file svchost.exe.manifest dengan notepad lalu copy configurasi berikut ini.
7. Silahkan compile dan jalankan aplikasinya. (jangan lupa untuk menyertakan file EASendMailObj.dll dan svchost.exe.manifest dalam satu folder svchost.exe jika ingin menjalankan nya dikomputer lain).

DOWNLOAD PROJECT VB6