مكتبة الاكواد

السلام عليكم

هذا الكود الثاني

لحصر الفارة داخل الفورم وفك الحصر

يحتاج الى زرين فقط

Coming Soon

' ضع هذا الكود في الفورم

Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Private Type POINT
X As Long
Y As Long
End Type


Private Sub Command1_Click() 'هذا الايعاز يجعل الماوس لا يخرج عن نطاق الفورم
Dim Client As RECT
Dim Up As POINT
ClientToScreen Me.hwnd, Up
GetClientRect Me.hwnd, Client
OffsetRect Client, Up.X, Up.Y
Up.X = Client.Left
Up.Y = Client.Top
ClipCursor Client
End Sub


Private Sub Command2_Click() 'هذا الايعاز يحرر حركة الماوس
ClipCursor ByVal 0&
End Sub

' في هذا المثال سوف تنحصر حركة الماوس داخل الفورم
' كما يمكنك حصرها داخل أي أداة أخرى
' me.hwnd   باستبدال الكلمة
'أو غيرها  text1.hwnd   , label1.hwnd باسم

السلام عليكم

هذا الكود الثالث

ولا يحتاج الى أي شي

وهو رسم خطين متقاطعين على حسب حركة الفارة

ويمكنك تغير لون الخطين

' ضع هذا الكود في الفورم

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
Me.Cls 
Line (X, 0)-(X, Me.ScaleHeight), vbRed 
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen 
End Sub

السلام عليكم

هذا الكود لصهر الشاشة حلو

لا يحتاج الى أي شي

Coming Soon

قريباً

' ضع هذا الكود في الفورم

Private Declare Function GetDC Lib "user32" (ByVal hwnd 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

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
Dim lngDC As Long
Dim intWidth As Integer, intHeight As Integer
Dim intX As Integer, intY As Integer

lngDC = GetDC(0)

intWidth = Screen.Width / Screen.TwipsPerPixelX
intHeight = Screen.Height / Screen.TwipsPerPixelY

form1.Width = intWidth * 15
form1.Height = intHeight * 15

Call BitBlt(hDC, 0, 0, intWidth, intHeight, lngDC, 0, 0, vbSrcCopy)
form1.Visible = vbTrue

Do
intX = (intWidth - 128) * Rnd
intY = (intHeight - 128) * Rnd

Call BitBlt(lngDC, intX, intY + 1, 128, 128, lngDC, intX, intY, vbSrcCopy)

DoEvents
Loop
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set form1 = Nothing
End
End Sub

السلام عليكم

هذا الكود لطباعة النص فقط

ويحتاج الى زر فقط

' ضع هذا الكود في الفورم

Private Sub Command1_Click()

Printer.Print text1.text

End Sub

السلام عليكم

هذا الكود لا يحتاج الى شي

هذا الكود لتشغيل البرنامج لعدد معين

' ضع هذا الكود في الفورم

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 Me
End If
End Sub

تلوين النموذج قبل اغلاقة

'ضع هذا الكود في الفورم

Private Sub Form_Unload(Cancel As Integer)
WindowState = 2     'تكبير حجم النموذج ليصبح بحجم الشاشة
DrawWidth = 4       'اتغيير حجم نقطة الرسم
For i = 1 To 18000  'التحضير للتنفيذ
Down = Down + 1     ' سرعة الرسم
Across = Across + 1
PSet (Rnd * Across, Rnd * Down), QBColor(Rnd * 15) 'رسم النقط
Next i            '  اعد تنقيذ الرسم
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

السلام عليكم

هذا الكود لوضع الخطوط في أدة Combo

يحتاج الى اداة Combo

كود حلو

'ضع هذا الكود في الفورم

Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub

السلام عليكم

هذا الكود حلو وجميل وممتاز

لصنع فجوة بالفورم

لا يحتاج الى شي

' ضع هذا الكود في الفورم

Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean

Const RGN_DIFF = 4

Dim lOriginalForm As Long

Dim ltheHole As Long

Dim lNewForm As Long

Dim lFwidth As Single

Dim lFHeight As Single

Dim lborder_width As Single

Dim ltitle_height As Single

On Error GoTo Trap

lFwidth = ScaleX(Width, vbTwips, vbPixels)

lFHeight = ScaleY(Height, vbTwips, vbPixels)

lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)

lborder_width = (lFHeight - ScaleWidth) / 2

ltitle_height = lFHeight - lborder_width - ScaleHeight

Select Case AreaType

Case "Elliptic"

ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

Case "RectAngle"

ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

Case "RoundRect"

ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))

Case "Circle"

ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))

Case Else

MsgBox "Unknown Shape!!"

Exit Function

End Select

lNewForm = CreateRectRgn(0, 0, 0, 0)

CombineRgn lNewForm, lOriginalForm, ltheHole, RGN_DIFF

SetWindowRgn hWnd, lNewForm, True

Me.Refresh

fMakeATranspArea = True

Exit Function

Trap:

MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description

End Function

Private Sub Form_Load()

Dim lParam(1 To 6) As Long

lParam(1) = 100

lParam(2) = 208

lParam(3) = 50

lParam(4) = 50

lParam(5) = 666

lParam(6) = 555

'Call fMakeATranspArea("RoundRect", lParam())

'Call fMakeATranspArea("RectAngle", lParam())

'Call fMakeATranspArea("Circle", lParam())

Call fMakeATranspArea("Elliptic", lParam())

End Sub

السلام عليكم

هذا الكود لتجميل الفورم

'ضع هذا الكود في الفورم

Private Sub Form_Load()
    Me.AutoRedraw = True
    Me.ScaleMode = vbTwips
    Me.Caption = "Rainbow Generator by " & _
    "K. O. Thaha Hussain"
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

فتح الفورم بشكل جميل

' ضع هذا الكود في الفورم

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

بس انا الي اشارك بالكود

شاركوا ياشباب يامبرمجين

:)

هذا لوضع اجهزه الطابعة في قائمة مندلسه

تحتاج الى Combo

'ضع هذا الكود في الفورم

Private Sub Form_Load()
Dim cPrinter As Printer
For Each cPrinter In Printers
    Combo1.AddItem Printer.DeviceName
Next
End Sub

حركة عند اغلاق الفورم جميله

' ضع هذا الكود في الفورم

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
DoEvents
frmSlide.Left = frmSlide.Left + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 100)
End Sub

اخى انا اقدر تعبك ومجهودك الرائع والمستمر لكن اتمنى ان توفر عليك عناء الشرح لانه توجد مكتبة ممتازة من الاكواد وهى المكتبة الخاصة بالمنتدى وهذه هى وصلتها

مكتبة اكواد الفريق العربى :rolleyes:

تحريك النص بطريقة جميله

تحتاج الى label

' ضع هذا الكود في الفورم

Private Sub Form_Load()
Me.Label1.Top = 0
End Sub

Private Sub Timer1_Timer()
a = Me.Height
b = 200
If Me.Label1.Top < a Then 'Me.Height Then
Me.Label1.Top = Me.Label1.Top + b
Exit Sub
End If
For m = 1 To (Int(a / b) + 1)
Me.Label1.Top = Me.Label1.Top - 200
For x = 1 To 1000000
Next
Next
End Sub

فورم شفاف

' ضع هذا الكود في الفورم

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000

Private Sub Form_Load()
   SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
   SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA
End Sub

طباعة صفحة انترنت طبعا تحتاج الى اداة الانترنت

'تأكد من وجود الملف MSHTML.DLL في مجلد ال system

Public Declare Function OpenProcess Lib "kernel32" _
        (ByVal dwDesiredAccess As Long, _
        ByVal bInheritHandle As Long, _
        ByVal dwProcessId As Long) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" _
        (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" _
        (ByVal hObject As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias
"GetSystemDirectoryA" _
        (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STATUS_PENDING = &H103&

Public Sub PrintHtmlFile(cHtmlFile As String)
    Dim hProcess As Long
    Dim ProcessId As Long
    Dim ExitCode As Long
    Dim cWinSysDir As String
    cWinSysDir = String(254, " ")
    Call GetSystemDirectory(cWinSysDir, Len(cWinSysDir))
    cWinSysDir = Trim(Left(cWinSysDir, InStr(cWinSysDir, Chr(0)) - 1))
    If Dir(cWinSysDir & "\MSHTML.DLL") <> "" Then
        ProcessId = Shell("rundll32.exe " & cWinSysDir &
        "\MSHTML.DLL,PrintHTML " & Chr(34) & cHtmlFile & Chr(34), vbNormalFocus)
        hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId)
        Do
            Call GetExitCodeProcess(hProcess, ExitCode)
            DoEvents
        Loop While ExitCode = STATUS_PENDING
        Call CloseHandle(hProcess)
    End If
End Sub

كود بسيط لجعل الفورم بالمقدمة

' ضع هذا الكود في الفورم

Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Sub Form_Load()
Timer1.Interval = 1
End Sub
Private Sub Timer1_Timer()
SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3
End Sub

إلغاء تفعيل زر التكبير في أعلى النافذة

' ضع هذا الكود في الفورم

Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Sub Form_Load()
  Const WS_MAXIMIZEBOX = &H10000
  Const GWL_STYLE = (-16)
  Const SWP_FRAMECHANGED = &H20
  Const SWP_NOMOVE = &H2
  Const SWP_NOSIZE = &H1

  Dim nStyle As Long
  nStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
  Call SetWindowLong(Me.hWnd, GWL_STYLE, nStyle And Not WS_MAXIMIZEBOX)
  SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
End Sub

إلغاء تفعيل زر الإغلاق في أعلى النافذة

' ضع هذا الكود في الموديول
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long 

Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long 

Public Const MF_BYPOSITION = &H400&

' ضع هذا الكود في الفورم
Public Sub DisableCloseWindowButton(frm As Form) 

   Dim hSysMenu As Long 

   'Get the handle to this windows system menu 
   hSysMenu = GetSystemMenu(frm.hwnd, 0) 

   'Remove the Close menu item This will also disable the close button 
   RemoveMenu hSysMenu, 6, MF_BYPOSITION 

   'Lastly, we remove the seperator bar 
   RemoveMenu hSysMenu, 5, MF_BYPOSITION 

End Sub

Private Sub Form_Load() 
   DisableCloseWindowButton Me 
End Sub

أبطال زر x في اعلى النافذه

' ضع هذا الكود في الفورم

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = True
End Sub

جعل الفورم بالمقدمة بس الكود طويل

' ضع هذا الكود في الفورم

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
   lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
   lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
   SetOnTop Form1.hwnd, True
End Sub

ترجمة النجوم ********

' ضع هذا الكود في الفورم

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
       x As Long
       y As Long
End Type
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Form_Load()
Timer1.Interval = 10
End Sub

Private Sub Timer1_Timer()
Const EM_SETPASSWORDCHAR = &HCC
Dim coord As POINTAPI

s = GetCursorPos(coord)
x = coord.x
y = coord.y

h = WindowFromPoint(x, y)

Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub