أكواد للمبتدئين

(f)الكود الخامس والتسعون(f)

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

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

جزاك الله كل خير أخي

(f)الكود السادس والتسعون(f)

السماح بإدخال تاريخ فقط في مربع النص.

Dim i As Integer

Dim t1 As String

Dim t2 As String

Public Sub AutoDate(TextBoxName As TextBox, ByVal keyasci As Integer)

    If Val(keyasci) = 8 Then

        If TextBoxName.Text = Empty Then

            i = 0

        Else

            i = i - 1

        End If

        Exit Sub

    End If

    i = i + 1

    If i = 3 Then

        t1 = Mid(TextBoxName.Text, 1, 2)

        t2 = Mid(TextBoxName.Text, 3, 1)

        TextBoxName.Text = Trim$(t1) & "/" & t2

        TextBoxName.SelStart = 4

        t2 = Empty

    ElseIf i = 6 Then

        t1 = Mid(TextBoxName.Text, 1, 5)

        t2 = Mid(TextBoxName.Text, 6, 1)

        TextBoxName.Text = Trim$(t1) & "/" & t2

        TextBoxName.SelStart = 7

        End If

    If i = 11 Then Exit Sub

End Sub

Public Function DateValidation(TextBoxName As TextBox) As Boolean

    If IsDate(Trim$(TextBoxName.Text)) = False Then

        MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."

        TextBoxName.SetFocus

        DateValidation = False

    ElseIf Not Len(Trim$(TextBoxName.Text)) = 10 Then

        MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."

        TextBoxName.SetFocus

        DateValidation = False

    Else

        DateValidation = True

    End If

End Function

Private Sub Text1_KeyPress(KeyAscii As Integer)

Call AutoDate(Text1, 0)

End Sub

Private Sub Text1_LostFocus()

Call DateValidation(Text1)

End Sub

(f)الكود السابع والتسعون(f)

السماح بكتابة أرقام فقط داخل مربع النص.

Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then

KeyAscii = 0

End If

End Sub

(f)الكود الثامن والتسعون(f)

السماح بكتابة حروف إنجليزية فقط في مربع النص.

Private Sub Text1_KeyPress(KeyAscii As Integer)

If (KeyAscii >= Asc("a") And KeyAscii <= Asc("z")) Or (KeyAscii >= Asc("A") And KeyAscii <= Asc("Z")) Then

Else

KeyAscii = 0

End If

End Sub

(f)الكود التاسع والتسعون(f)

كود بسيط لالتقاط صورة للشاشة في الحافظة.

Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Sub Command1_Click()

    keybd_event vbKeySnapshot, 0, 0, 0

    DoEvents

End Sub

(f)الكود المائة(f)

ظهور الفورم بأحجام وألوان عشوائية ... تخاريف:D

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

(f)الكود الأول بعد المائة(f)

ظهور الـ Label في أماكن عشوائية وبألوان عشوائية.

Private Sub Form_Load()

Timer1.Interval = 250

End Sub



Private Sub Timer1_Timer()

   Randomize

   Label1.ForeColor = QBColor(Rnd * 13)

   Label1.Left = RGB(Rnd * 255, Rnd * 255, Rnd * 255)

   Label1.Move Rnd * 10000, Rnd * 9000, Rnd * 12000, Rnd * 9000

   End Sub

(f)الكود الثاني بعد المائة(f)

تحريك 2 Label مع تغيير ألوانهما.

Private Sub Form_Load()

Timer1.Interval = 100

Timer2.Interval = 100

Label1 = "Welcome"

Label2 = "Good Bey"

End Sub



Private Sub Timer1_Timer()

Label1.ForeColor = QBColor(Rnd * 15)

Label1.Left = Label1.Left + 10

End Sub



Private Sub Timer2_Timer()

Label2.ForeColor = QBColor(Rnd * 10)

Label2.Left = Label2.Left - 10

End Sub

(f)الكود الثالث بعد المائة(f)

تحريك Label بشكل طولي.

Private Sub Form_Load()

Timer1.Interval = 100

End Sub

Private Sub Timer1_Timer()

 Label1.Move 2000, Label1.Top - 100

    If Label1.Top < 0 Then

        Label1.Top = Form1.Height

    End If

End Sub

(f)الكود الرابع بعد المائة(f)

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

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

(f)الكود الخامس بعد المائة(f)

لرسم دوائر ملونة رائعة جداً باستخدام الماوس.

Private Sub Command1_Click()

Form1.Cls

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim i As Integer

i = Rnd * 15

If Button = 1 Then

Me.Circle (X, Y), 200, QBColor(i)

End If

End Sub

(f)الكود السادس بعد المائة(f)

لصنع فجوة داخل الفورم (دائرة - مربع - مستطيل).

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

(f)الكود السابع بعد المائة(f)

لمسح ما يوجد داخل كل مربعات النص الموجودة على الفورم.

Public Sub ClearTextBoxes(frm As Form)

    Dim c As Control

    For Each c In frm

        If TypeOf c Is TextBox Then c.Text = ""

    Next c

End Sub

Private Sub Command1_Click()

Call ClearTextBoxes(Form1)

End Sub

الكود الثامن بعد المائة

لإنشاء مربع نص وقت تنفيذ البرنامج.

Private Sub Form_Load()

Form1.Controls.Add "VB.textbox", "Textcreate", Form1

Form1!Textcreate.Visible = True

End Sub

فعلا اكواد رائعة و الي الامام اتمني لك التوفيق من كل قلبي ;)

أنت الأروع Bibo2002 ... وبالتوفيق للجميع :)

رائع ومشكووووووووووووووووووووووور(f):)

يعطيك العافية وجهد تشكر علية

اقتباس

كاتب الرسالة الأصلية : mr_m

اشكرك اخي من كل اعماق قلبي واتمنى  لك التوفيق على ماتقدمة واعانك  

(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)  .................. (f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(

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

...........................(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)........................

عليهم  واسأل الله ان يجزيك عنى كل خير  

(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)(f)

(f) صقر الزمان (f) mr_m (f) معاون (f) S H E Z O N (f)

شكراً لكم....

يعطيك العافية

الله يعافيك أخي معاون وآسف لتأخري في طرح أكواد جديدة ،،، ولكن سأحاول في القريب العاجل بإذن الله .... وللجميع تحياتي (f)(f)

إلى الأخ العزيز عبد الله فتحي ..

السلام عليكم ورحمة الله وبركاته .

اريد ان اشكرك الشكر الجزيل على المجهود الذي تبذله من اجلنا .. :o

جعله الله في ميزان حسناتك انه سميع الدعاء .

ننتظر المزيد ....... والمزيد .. ;) ;)