[ALL] Client Estavel

Código:

Private Sub txtChat_GotFocus()

Código:

Private Sub txtChat_GotFocus()
On Error Resume Next
    frmMirage.txtMyTextBox.SetFocus
End Sub

Código:

Private Sub picScreen_GotFocus()

Código:

Private Sub picScreen_GotFocus()
On Error Resume Next
    frmMirage.txtMyTextBox.SetFocus
End Sub

Código:

Sub ClearRainDrop(ByVal RDNumber As Long)

Código:

Sub ClearRainDrop(ByVal RDNumber As Long)
On Error Resume Next
    DropRain(RDNumber).x = 0
    DropRain(RDNumber).y = 0
    DropRain(RDNumber).speed = 0
    DropRain(RDNumber).Randomized = False
End Sub

Código:

Sub ClearSnowDrop(ByVal RDNumber As Long)

Código:

Sub ClearSnowDrop(ByVal RDNumber As Long)
On Error Resume Next
    DropSnow(RDNumber).x = 0
    DropSnow(RDNumber).y = 0
    DropSnow(RDNumber).speed = 0
    DropSnow(RDNumber).Randomized = False
End Sub

Código:

Public Function CaptureScreen() As Picture

Código:

Public Function CaptureScreen() As Picture
Dim hWndScreen As Long
On Error Resume Next
hWndScreen = GetDesktopWindow()
Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY)
End Function

Código:

Public Function CaptureForm(frmSrc As Form) As Picture

Código:

Public Function CaptureForm(frmSrc As Form) As Picture
On Error Resume Next
Set CaptureForm = CaptureWindow(frmSrc.hwnd, False, 0, 0, frmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), frmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))
End Function

Código:

Public Function CaptureClient(frmSrc As Form) As Picture

Código:

Public Function CaptureClient(frmSrc As Form) As Picture
On Error Resume Next
Set CaptureClient = CaptureWindow(frmSrc.hwnd, True, 0, 0, frmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), frmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))
End Function

Código:

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

Código:

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
On Error Resume Next
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic) ' Length of structure.
.Type = vbPicTypeBitmap ' Type of Picture (bitmap).
.hBmp = hBmp ' Handle to bitmap(GetPlayerMap(myindex)).
.hPal = hPal ' Handle to palette (may be null).
End With
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
Set CreateBitmapPicture = IPic
End Function

Código:

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture

Código:

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
On Error Resume Next
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev 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
If Client Then
hDCSrc = GetDC(hWndSrc) ' Get device context for client area.
Else
hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire window.
End If
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette support.
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of palette.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
GetSystemPaletteEntries hDCSrc, 0, 256, LogPal.palPalEntry(0)
hPal = CreatePalette(LogPal)
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
RealizePalette hDCMemory
End If
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
DeleteDC hDCMemory
ReleaseDC hWndSrc, hDCSrc
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Código:

Public Function CaptureArea(frmSrc As Form, Left As Long, Top As Long, Width As Long, Height As Long) As Picture

Código:

Public Function CaptureArea(frmSrc As Form, Left As Long, Top As Long, Width As Long, Height As Long) As Picture
On Error Resume Next
Set CaptureArea = CaptureWindow(frmSrc.hwnd, True, Left, Top, Width, Height)
End Function

Código:

Public Function CaptureActiveWindow() As Picture

Código:

Public Function CaptureActiveWindow() As Picture
Dim hWndActive As Long
Dim RectActive As RECT
On Error Resume Next
hWndActive = GetForegroundWindow()
GetWindowRect hWndActive, RectActive
Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End Function

Código:

Sub GameInit()

Código:

Sub GameInit()
On Error Resume Next
    frmMirage.Show
    frmSendGetData.Hide
    Unload frmMainMenu
    Call InitDirectX
End Sub

Código:

Sub GameLoop()
Dim Tick As Long
Dim TickFPS As Long
Dim FPS As Long
Dim x As Long
Dim y As Long
Dim I As Long
Dim rec_back As RECT

Código:

On Error Resume Next

Código:

frmSpellEditor.Show vbModal

Código:

On Error Resume Next

Código:

Public Sub NpcEditorInit()

Código:

On Error Resume Next

Terabin escreveu:Não achei muito útil afinal isso não fara com que o servidor pare de cair ou que o cliente não de erros,como sugere o nome do tópico.
isso é mais uma melhoria no código

creditos batista pois ele disponibilizo não é a primeira vez que pegam um tutorial e dizem ser seus vergonha isso

Aonde que encher o código de "Se der erro ignorar e passar para próximo", vai deixar o client estável?

Isso é coisa de preguiçoso, no momento que ocorre um erro, este deve ser solucionado...

O mais recomendado, que se crie uma txt na pasta do cliente com o nome ERROS.txt, e insira isso em cada Sub:

No inicio da Sub

On Error GoTo Erro

e antes da End Sub

Erro:

f = FreeFile
Open App.Path & "\ERROS.txt" For Append As #f
Print #f, ( "NOMEDASUB" & " RTE:" & Err & " " & Time & " " & Date)
Close #f

Código:

Private Sub txtChat_GotFocus()

Lukas desculpe então se não quer por do bastita ponha os meus por posta aqui no tópico de Duvida do membro DBZAERO acho que você se recorda