الرئيسية
كود لتخطي مواقع الفحص المشهوره
كود:
' 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
كود:
' 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
