D3DX8 ScreenShots

[Ertzel]

This tutorial is for any system using the newest version of rendering in Eclipse. Currently the screenshot button does duck all and is completely useless. This removes the screenshot button completely and adds a new code for taking screenshots that any player can do and shows the whole game screen.

It is a very simple tutorial also.

First remove anything to do with the current screenshot system except the picSSMap picturebox on frmMain.

Add the following anywhere (I created a new mod called modScreenShot):

```

Option Explicit

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

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long

Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long

Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapability As Long) As Long

Private Declare Function GetForegroundWindow Lib "user32" () As Long

Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long

Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetDC Lib "user32" Alias "GetDc" (ByVal hwnd As Long) As Long

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fpictureOwnsHandle As Long, IPIC As IPicture) As Long

Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, 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 SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long

Global Const INVERSE = 6

Const SOLID = 0

Const DOT = 2

Global HoldX As Single

Global HoldY As Single

Global StartX As Single

Global StartY As Single

Global SavedDrawStyle

Global SavedMode

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

End Type

Private Type GUID

data1 As Long

Data2 As Integer

Data3 As Integer

Data4(7) As Byte

End Type

Private Const RASTERCAPS As Long = 38

Private Const RC_PALETTE As Long = &H100

Private Const SIZEPALETTE As Long = 104

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

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hpal As Long) As Picture

On Error GoTo error

Dim r As Long

Dim pic As PicBmp

Dim IPIC As IPicture

Dim IID_DisPatch As GUID

With IID_DisPatch

.data1 = &H20400

.Data4(0) = &HC0

.Data4(7) = &H46

End With

With pic

.Size = Len(pic)

.Type = vbPicTypeBitmap

.hBmp = hBmp

.hpal = hpal

End With

r = OleCreatePictureIndirect(pic, IID_DisPatch, 1, IPIC)

Set CreateBitmapPicture = IPIC

Exit Function

error:

Resume Next

End Function

Public Function CaptureWindow(ByVal hWndSrc As Long, 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 rc 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

hDCSrc = GetWindowDC(hWndSrc)

hDCMemory = CreateCompatibleDC(hDCSrc)

hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, Heightsrc)

hBmpPrev = SelectObject(hDCMemory, hBmp)

RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)

HasPaletteScrn = RasterCapsScrn And RC_PALETTE

PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then

LogPal.palversion = &H300

LogPal.palNumEntries = 256

rc = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palpalEntry(0))

hpal = CreatePalette(LogPal)

hpal = SelectPalette(hDCMemory, hpal, 0)

rc = RealizePalette(hDCMemory)

End If

rc = BitBlt(hDCMemory, 0, 0, WidthSrc, Heightsrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

hBmp = SelectObject(hDCMemory, hBmpPrev)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then

hpal = SelectPalette(hDCMemory, hpalPrev, 0)

End If

rc = DeleteDC(hDCMemory)

rc = ReleaseDC(hWndSrc, hDCSrc)

Set CaptureWindow = CreateBitmapPicture(hBmp, hpal)

Exit Function

ErrorRoutineErr:

MsgBox "Create window " & Err & error

Resume Next

End Function

Public Function CaptureForm(frmsrc As Form) As Picture

On Error GoTo errorroutineerror

Set CaptureForm = CaptureWindow(frmsrc.hwnd, 0, 0, frmsrc.ScaleX(frmsrc.Width, vbTwips, vbPixels), frmsrc.ScaleY(frmsrc.Height, vbTwips, vbPixels))

Exit Function

errorroutineerror:

MsgBox "form : " & Err & error

End Function

```

Next, go into```
Public Sub CheckInputKeys()
```and anywhere in there add:```

' Screenshot Map

If GetKeyState(vbKeySnapshot) < 0 Then ' vbKeySnapshot = Print Screen button

Sleep 200 ' Sleep for 200 miliseconds to avoid double pictures

Dim sFilePath As String, num As Long, wasFound As Boolean

wasFound = False

For num = 1 To 255

sFilePath = App.Path & "\ScreenShots\map" & GetPlayerMap(MyIndex) & "[" & num & "].jpg"

If Not FileExist(sFilePath, True) Then

frmMain.picSSMap.Picture = captureform(frmMain)

SavePicture frmMain.picSSMap.Picture, App.Path & "\ScreenShots\map" & GetPlayerMap(MyIndex) & "[" & num & "].jpg"

Exit Sub

End If

Next

If wasFound Then

MsgBox "The maximum screenshots for this map have been reached! Delete some if you wish to take more...", vbOKOnly

End If

End If

```

In your client folder create a new folder named ScreenShots.

This will make it so now when you press the PrintScreen button on your keyboard, it renders everything sown on frmMain to picSSMap and then saves picSSMap.Picture into a image called map (YourMapNumber) [MapImagesCount].jpg and can save up to 255 images per map. You can change that number or saving format to fit your own needs.

Example of Screenshots folder:


[clark]

Looking Good i'm going to try this later , i have a question is that possible to make a screenshot of the entire map (even if not completly visible on the game screen) with this code? and if yes how?

[Ertzel]

No, this only renders what is on a form or your whole computer screen. Since the rest of the map is never drawn anywhere, this has no way of saving/rendering the rest of your map.

[Growlith1223]

-snip-

forgot that it's using the computer's screenshot function

[Ertzel]

> by making this system render to a picturebox, resize the picturebox to the max values then take the screenshot

That wont work. It is already rendering to a picturebox and saving the image but it can only rendering either your whole computer screen with CaptureScreen() or a form with captureform(). It has no way of knowing the rest of the map.

I guess in theory you could make a script to render the rest of map to a picturebox instead of rendering the frmMain to the picturebox. Then taking your image from there. But that's a completely different system really.

[clark]

> No, this only renders what is on a form or your whole computer screen. Since the rest of the map is never drawn anywhere, this has no way of saving/rendering the rest of your map.

Ok , Thanks.

[Growlith1223]

i already fixed my post..

[DarkDino]

Oh nice !

[barreytor]

Nice, only thing I'd change is the screenchot naming, and use "Date-Time-ScreenshotNum" instead.

That would allow for up to 255 screens saved for every second instead of map.

[Ertzel]

This is untested but for that you should be able to Replace:

```

' Screenshot Map

If GetKeyState(vbKeySnapshot) < 0 Then ' vbKeySnapshot = Print Screen button

Sleep 200 ' Sleep for 200 miliseconds to avoid double pictures

Dim sFilePath As String, num As Long, wasFound As Boolean

wasFound = False

For num = 1 To 255

sFilePath = App.Path & "\ScreenShots\map" & GetPlayerMap(MyIndex) & "[" & num & "].jpg"

If Not FileExist(sFilePath, True) Then

frmMain.picSSMap.Picture = captureform(frmMain)

SavePicture frmMain.picSSMap.Picture, App.Path & "\ScreenShots\map" & GetPlayerMap(MyIndex) & "[" & num & "].jpg"

Exit Sub

End If

Next

If wasFound Then

MsgBox "The maximum screenshots for this map have been reached! Delete some if you wish to take more...", vbOKOnly

End If

End If

```

With:

```

If GetKeyState(vbKeySnapshot) < 0 Then ' vbKeySnapshot = Print Screen button

Sleep 200 ' Sleep for 200 miliseconds to avoid double pictures

Dim sFilePath As String, num As Long, wasFound As Boolean, dtmTest As Date

dtmTest = DateValue(Now)

wasFound = False

For num = 1 To 255

sFilePath = App.Path & "\ScreenShots\map" & GetPlayerMap(MyIndex) & "[" & dtmTest & "].jpg"

If Not FileExist(sFilePath, True) Then

frmMain.picSSMap.Picture = captureform(frmMain)

SavePicture frmMain.picSSMap.Picture, sFilePath

Exit Sub

End If

Next

If wasFound Then

MsgBox "The maximum screenshots for this map have been reached! Delete some if you wish to take more...", vbOKOnly

End If

End If

```

and then it will save the dat/time in []'s instead of a number from 1-255.