development-point - اكواد للفيوجل بيسك 6 روعــه من تجميعي

هادا اول موضوع لي في المنتدى وارجو ان اكون قد ادتكم

كود لتخطي مواقع الفحص المشهوره
كود:
' This CodeD By : DeaD SouL

Option Explicit

Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088

Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
'Private Const CREATE_NEW = 1
Private Const CREATE_ALWAYS = 2

Private Type IDEREGS
bFeaturesReg As Byte
bSectorCountReg As Byte
bSectorNumberReg As Byte
bCylLowReg As Byte
bCylHighReg As Byte
bDriveHeadReg As Byte
bCommandReg As Byte
bReserved As Byte
End Type

Private Type SENDCMDINPARAMS
cBufferSize As Long
irDriveRegs As IDEREGS
bDriveNumber As Byte
bReserved(1 To 3) As Byte
dwReserved(1 To 4) As Long
End Type

Private Type DRIVERSTATUS
bDriveError As Byte
bIDEStatus As Byte
bReserved(1 To 2) As Byte
dwReserved(1 To 2) As Long
End Type

Private Type SENDCMDOUTPARAMS
cBufferSize As Long
DStatus As DRIVERSTATUS
bBuffer(1 To 512) As Byte
End Type

Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByVal lpOverlapped As Long) As Long
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private mvarCurrentDrive As Byte
Private mvarPlatform As String

Public Function GetPhysicalDriveModelName() As String

Dim bin As SENDCMDINPARAMS
Dim bout As SENDCMDOUTPARAMS
Dim hdh As Long
Dim br As Long
Dim ix As Long
Dim sTemp As String

hdh = CreateFileA("\\.\PhysicalDrive0", GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)

ZeroMemory bin, Len(bin)
ZeroMemory bout, Len(bout)

With bin
.bDriveNumber = mvarCurrentDrive
.cBufferSize = 512
With .irDriveRegs
If (mvarCurrentDrive And 1) Then
.bDriveHeadReg = &HB0
Else
.bDriveHeadReg = &HA0
End If
.bCommandReg = &HEC
.bSectorCountReg = 1
.bSectorNumberReg = 1
End With
End With

DeviceIoControl hdh, DFP_RECEIVE_DRIVE_DATA, bin, Len(bin), bout, Len(bout), br, 0

For ix = 55 To 94 Step 2
If bout.bBuffer(ix + 1) = 0 Then Exit For
sTemp = sTemp & Chr(bout.bBuffer(ix + 1))
If bout.bBuffer(ix) = 0 Then Exit For
sTemp = sTemp & Chr(bout.bBuffer(ix))
Next ix

CloseHandle hdh
GetPhysicalDriveModelName = Trim(sTemp)
End Function

Public Sub PrintSandboxed(szMsg As String)
Dim hFile As Long
hFile = CreateFileA(szMsg, GENERIC_WRITE, 0, 0&, CREATE_ALWAYS, 0, 0&)
CloseHandle hFile
End Sub

او هذا كود ثاني هم تخطي بعد مواقع القحص

هذا اتخليه في الموديل

كود:
Option Explicit

Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hObject As Long)
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long

Private Const TH32CS_SNAPPROCESS = &H2
Private Const MAX_PATH As Long = 260

Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type

Function vm()
Dim oAdapters As Object
Dim oCard As Object
Dim SQL As String

' Abfrage erstellen
SQL = "SELECT * FROM Win32_VideoController"
Set oAdapters = GetObject("winmgmts:").ExecQuery(SQL)

' Auflisten aller Grafikadapter
For Each oCard In oAdapters
Select Case oCard.Description

Case "VM Additions S3 Trio32/64"
MsgBox "MS VPC with Additions found!", vbInformation

Case "S3 Trio32/64"
MsgBox "MS VPC without Additions found!", vbInformation

Case "VirtualBox Graphics Adapter"
MsgBox "VirtualBox with Additions found!", vbInformation

Case "VMware SVGA II"
MsgBox "VMWare with Additions found!", vbInformation

Case ""
MsgBox "VM found!", vbInformation

Case Else
MsgBox "I'm not running in a VM!", vbInformation
End Select

Next
End Function

Public Function Sandboxed() As Boolean
Dim nSnapshot As Long, nProcess As PROCESSENTRY32
Dim nResult As Long, ParentID As Long, IDCheck As Boolean
Dim nProcessID As Long

'Eigene ProcessID ermitteln
nProcessID = GetCurrentProcessId
If nProcessID 0 Then
'Abbild der Prozesse machen
nSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
If nSnapshot 0 Then
nProcess.dwSize = Len(nProcess)

'Zeiger auf ersten Prozess bewegen
nResult = ProcessFirst(nSnapshot, nProcess)

Do Until nResult = 0
'Nach der eigenen ProcessID suchen.
If nProcess.th32ProcessID = nProcessID Then

'Wir merken uns die ParentProcessID
ParentID = nProcess.th32ParentProcessID

'Wir beginnen nochmal beim ersten Prozess
nResult = ProcessFirst(nSnapshot, nProcess)
Do Until nResult = 0
'Wir suchen den Process mit der ParentID
If nProcess.th32ProcessID = ParentID Then
'Falls so ein Prozess vorhanden ist, dann ist das Programm nicht sandboxed
IDCheck = False
Exit Do
Else
IDCheck = True
nResult = ProcessNext(nSnapshot, nProcess)
End If
Loop

'Falls check True ist, dann ist das Programm Sandboxed
Sandboxed = IDCheck

Exit Do
Else
'Zum nchsten Prozess
nResult = ProcessNext(nSnapshot, nProcess)
End If
Loop
Handle wird geschloكen
CloseHandle nSnapshot
End If
End If
End Function

هذا كود لتعطيل الموس ولكيبورد عن تجربتي او مضمون

بلفروم لورد
كود:
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()
DoEvents
' إيقاف لوحة المفاتيح والماوس عن العمل
BlockInput True
' الانتظار عشر ثواني
Sleep 10000
' إعادة لوحة المفاتيح والماوس للعمل مرة أخرى
BlockInput False
End Sub
كود تلوين الفروم بالوان قوز قزح هـع
كود:
Private Sub Form_Load()
Me.AutoRedraw = True
Me.ScaleMode = vbTwips
Me.Caption = "Rainbow Generator by " & _
"ghost baghdad"
End Sub
Private Sub Form_Resize()
Call Rainbow
End Sub
Private Sub Rainbow()
On Error Resume Next
Dim Position As Integer, Red As Integer, Green As _
Integer, Blue As Integer
Dim ScaleFactor As Double, Length As Integer
ScaleFactor = Me.ScaleWidth / (255 * 6)
Length = Int(ScaleFactor * 255)
Position = 0
Red = 255
Blue = 1
For Green = 1 To Length
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green \ ScaleFactor, Blue)
Position = Position + 1
Next Green
For Red = Length To 1 Step -1
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red \ ScaleFactor, Green, Blue)
Position = Position + 1
Next Red
For Blue = 0 To Length
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green, Blue \ ScaleFactor)
Position = Position + 1
Next Blue
For Green = Length To 1 Step -1
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green \ ScaleFactor, Blue)
Position = Position + 1
Next Green
For Red = 1 To Length
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red \ ScaleFactor, Green, Blue)
Position = Position + 1
Next Red
For Blue = Length To 1 Step -1
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green, Blue \ ScaleFactor)
Position = Position + 1
Next Blue
End Sub
كود يخلي الفروم 3D
كود:
Public Sub ThreeDForm(frmForm As Form)
Const cPi = 3.1415926
Dim intLineWidth As Integer
intLineWidth = 5
Dim intSaveScaleMode As Integer
intSaveScaleMode = frmForm.ScaleMode
frmForm.ScaleMode = 3
Dim intScaleWidth As Integer
Dim intScaleHeight As Integer
intScaleWidth = frmForm.ScaleWidth
intScaleHeight = frmForm.ScaleHeight
frmForm.Cls
frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF
frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF
frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, _
intScaleHeight), &H808080, BF
frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, _
intScaleHeight), &H808080, BF
Dim intCircleWidth As Integer
intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth _
* intLineWidth)
frmForm.FillStyle = 0
frmForm.FillColor = QBColor(15)
frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), _
intCircleWidth, _
QBColor(15), -3.1415926, -3.90953745777778
frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), _
intCircleWidth, _
QBColor(15), -0.78539815, -1.5707963
frmForm.Line (0, intScaleHeight)-(0, 0), 0
frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0
frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, _
intScaleHeight - 1), 0
frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, _
intScaleHeight - 1), 0
frmForm.ScaleMode = intSaveScaleMode
End Sub

Private Sub Form_Resize()
ThreeDForm Me
End Sub
كود رش الالوان على الفروم عن تئشير الموس
كود:
Private Sub Form_Load()
Me.AutoRedraw = True
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
X = Me.CurrentX
Y = Me.CurrentY
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
End Sub
احلى كود او عجبني حيل كمان هههههههههههههه

جربوه او شوفو

هذا الكود خلوه في الفروم

كود:
private sub form_load()
timer1.interval = 250
end sub
او هذا الكود خلوه في التايمر

كود:
private sub timer1_timer()
randomize
me.backcolor = rgb(rnd * 255, rnd * 255, rnd * 255)
me.move rnd * 12000, rnd * 9000, rnd * 12000, rnd * 9000
end sub
هذا الكود يخلي الفروم ماينلزم لو تفحط ههههههههههه
بس تكدر اتوكفه من الفيوجل بيسك من التيست
______________________________

كود لفتح الفروم من الاصغر لاكبر كود روعه
كود:
Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next

End Sub
Private Sub Form_Load()
Explode Me
End Sub
كود يخلي الفروم فيه دوائر
كود:
function dist(x1, y1, x2, y2) as single
dim a as single, b as single
a = (x2 - y1) * (x2 - x1)
b = (y2 - y1) * (y2 - y1)
dist = sqr(a + b)
end function
sub moveit(a, b, t)
a = (1 - t) * a + t * b
end sub

private sub form_click()
cls
dim t as single, x1 as single, y1 as single
dim x2 as single, y2 as single, x3 as single
dim y3 as single, x4 as single, y4 as single

scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: Y1 = 200
x2 = 320: Y2 = 200
x3 = 320: Y3 = -200
x4 = -320: Y4 = -200
do until dist(x1, y1, x2, y2) < 10
line (x1, y1)-(x2, y2)
line -(x3, y3)
line -(x4, y4)
line -(x1, y1)
moveit x1, x2, t
moveit y1, y2, t
moveit x2, x3, t
moveit y2, y3, t
moveit x3, x4, t
moveit y3, y4, t
moveit x4, x1, t
moveit y4, y1, t
loop
end sub

private sub form_resize()
cls
dim t as single, x1 as single, y1 as single
dim x2 as single, y2 as single, x3 as single
dim y3 as single, x4 as single, y4 as single

scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: Y1 = 200
x2 = 320: Y2 = 200
x3 = 320: Y3 = -200
x4 = -320: Y4 = -200
do until dist(x1, y1, x2, y2) < 10
line (x1, y1)-(x2, y2)
line -(x3, y3)
line -(x4, y4)
line -(x1, y1)
moveit x1, x2, t
moveit y1, y2, t
moveit x2, x3, t
moveit y2, y3, t
moveit x3, x4, t
moveit y3, y4, t
moveit x4, x1, t
moveit y4, y1, t
loop
end sub
كود لانهاء البرنامج في 3 مرات مجرب مني

او ما تكدر اشغله وره الـ3 مرات
كود:
Private Sub Form_Load()
retvalue = GetSetting("A", "0", "Runcount")
GD$ = Val(retvalue) + 1
SaveSetting "A", "0", "RunCount", GD$
If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل
MsgBox "انتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية"
Unload FRM '
End If
End Sub
يتبع ان شاء الله

الي عندو اكواد تانية ضعها هنا من فضلك علشان تعم الفايدة