[ Visual Basic 6 ] مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت

الموضوع في 'قسم فيجوال بيسك 6 و لغة Delphi' بواسطة محمد الفسكاوى, بتاريخ ‏20 أكتوبر 2009.

تم تحميل الصفحة في 1,6551447 ثانية
  1. محمد الفسكاوى

    محمد الفسكاوى Developer

    إنضم إلينا في:
    ‏20 يوليو 2009
    المشاركات:
    324
    الإعجابات المتلقاة:
    60
    نقاط الجائزة:
    0
    Credits:
    0
    كيفكم اخوان

    اليوم جيبلكم اكواد مفيدة بالفيجول بيسك ان شاء الله تعجبكم
    الكود الاول
    لتحريك الكلام في عنوان الفورم و مربع النص
    لتنفيذه تحتاج
    timer
    **** box


    كود PHP:
    Private str**** As String
    Private Sub Form_Load()
    Timer1.Interval = 75
    str**** = "حط النص الى تريده هنا"
    str**** = Space(50) & str****
    End Sub
    Private Sub Timer1_Timer()
    str**** = Mid(str****, 2) & Left(str****, 1)
    ****1.**** = str****
    Me.Caption = str****
    End Sub

    الاتصال من خلال الاكواد
    المطلوب
    2 command
    و اضافة ال active x الخاصة بالمودام


    كود PHP:
    Private Sub Command1_Click()
    Dim PhoneNumber As String
    On Error GoTo WrongPort
    MSComm1.CommPort = 3 قم بتغير البورتات لتجد الرقم المناسب
    MSComm1.Settings = "300,n,8,1"
    PhoneNumber = "07770777"
    MSComm1.PortOpen = True
    MSComm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)
    Exit Sub
    WrongPort:
    MsgBox "Title", 1048576 + 524288 + 16, "Prompt"
    End Sub

    كود PHP:
    Private Sub Command2_Click()
    MSComm1.PortOpen = False
    End Sub

    Private Sub Form_Load()
    Command1.Caption = "&Connect"
    Command2.Caption = "&Disconnect"
    End Sub

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

    كود PHP:
    Private Const MAX_COMPUTER****_LENGTH As Long = 31
    Private Declare Function GetComputer**** Lib "kernel32" Alias "GetComputer****A" (ByVal lpBuffer As String, nSize As Long) As Long
    Private Sub Form_Load()
    Dim dwLen As Long
    Dim strString As String
    'Create a buffer
    dwLen = MAX_COMPUTER****_LENGTH + 1
    strString = String(dwLen, "X")
    'Get the computer ****
    GetComputer**** strString, dwLen
    'get only the actual data
    strString = Left(strString, dwLen)
    'Show the computer ****
    MsgBox strString
    End Sub

    لمعرفة اللون الذي يمر عليه الماوس
    تحتاج
    label box
    الكود

    كود PHP:
    Option Explicit
    Private Type POINTAPI
    x As Long
    y As Long
    End Type
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Sub Form_Load()
    Timer1.Interval = 100
    End Sub
    Private Sub Timer1_Timer()
    Dim tPOS As POINTAPI
    Dim sTmp As String
    Dim lColor As Long
    Dim lDC As Long

    lDC = GetWindowDC(0)
    Call GetCursorPos(tPOS)
    lColor = GetPixel(lDC, tPOS.x, tPOS.y)
    Label1.BackColor = lColor

    sTmp = Right$("000000" & Hex(lColor), 6)
    Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)
    End Sub

    لمعرفة نوع القرص (سيدي-صلب-قرص مرن)
    المطلوب
    ****box
    command button


    كود PHP:
    Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

    Private Sub Command1_Click()
    Me.AutoRedraw = True
    Select Case GetDriveType(****1.**** & ":\")
    Case 2
    Form1.Caption = "قرص مرن"
    Case 3
    Form1.Caption = "قرص طلب"
    Case Is = 4
    Form1.Caption = "Remote"
    Case Is = 5
    Form1.Caption = "Cd-Rom"
    Case Is = 6
    Form1.Caption = "Ram disk"
    Case Else
    Form1.Caption = "غير معين"
    End Select
    End Sub

    كود PHP:
    Private Sub Form_Load()
    Command1.Caption = "ادخل القرص الذي تريد معرفته"
    End Sub

    =======================================


    كود PHP:
    Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

    Public Sub OpenCDDriveDoor(ByVal State As Boolean)
    If State = True Then
    Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
    Else
    Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
    End If

     

     

    End Sub

    Private Sub Command1_Click()
    OpenCDDriveDoor (True)
    End Sub

    Private Sub Command2_Click()
    OpenCDDriveDoor (False)
    End Sub

    اخفاء شريط المهام


    كود PHP:
    Private Const SWP_HIDEWINDOW = &H80
    Private Const SWP_SHOWWINDOW = &H40

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClass**** As String, ByVal lpWindow**** As String) 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 Command1_Click()
    Dim Task As Long
    Task = FindWindow("****l_traywnd", "")
    Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
    End Sub

    Private Sub Command2_Click()
    Dim Task As Long
    Task = FindWindow("****l_traywnd", "")
    Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
    End Sub

    اخفاء ايقونات سطح المكتب واظهارها


    كود PHP:
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

    Private Sub Command1_Click()
    Dim hwnd As Long
    hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
    ShowWindow hwnd, 0
    End Sub

    Private Sub Command2_Click()
    Dim hwnd As Long
    hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
    ShowWindow hwnd, 5
    End Sub

    اخفاء محتويات محرك الاقراص


    كود PHP:
    Dim WSH As Object
    Set WSH = CreateObject("Wscript.****l")
    WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrive", 16, "REG_DWORD"

    تأجيل تنفيذ الكود لفترة معينة


    كود PHP:
    Public Sub Delay(HowLong As Date)
    TempTime = DateAdd("s", HowLong, Now)
    While TempTime > Now
    DoEvents
    Wend
    End Sub

    Private Sub Command1_Click()
    Delay 5
    MsgBox "Test"
    End Sub

    حفظ ما يتغير في الفورم بعد اغلاقه


    كود PHP:
    Private Sub Form_Load()
    ****1.**** = GetSetting(App.Title, "Settings", "SaveIn****1")
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
    SaveSetting App.Title, "Settings", "SaveIn****1", Trim(****1.****)
    End Sub

    الوظيفة Split لمستخدمي الاصدار الخامس


    كود PHP:
    length = Len(****)
    startIndex = 1

    Do While startIndex < length And resCount <> Limit
    ' get the next delimiter
    endIndex = InStr(startIndex, ****, Delimiter, CompareMethod)
    If endIndex = 0 Then endIndex = length + 1

    ' make room in the array, if necessary
    If resCount > UBound(res) Then
    ReDim Preserve res(0 To resCount + 99) As String
    End If
    ' store the new element
    res(resCount) = Mid$(****, startIndex, endIndex - startIndex)
    resCount = resCount + 1

    startIndex = endIndex + Len(Delimiter)
    Loop

    ' trim unused values
    ReDim Preserve res(0 To resCount - 1) As String

    return the array inside a Variant
    Split = res()

    End Function

    توليد أرقام عشوائية


    كود PHP:
    Dim RanNo() As Long
    Dim i, j, tmp

    Private Sub RandomizeNumbers(ByVal iFrom As Integer, ByVal iTo As Integer)
    ReDim RanNo(iFrom To iTo)
    For i = iFrom To iTo
    RanNo(i) = i
    Next i
    Randomize (Timer)
    For i = iFrom To iTo
    j = CInt((iTo - iFrom) * Rnd + iFrom)
    tmp = RanNo(i)
    RanNo(i) = RanNo(j)
    RanNo(j) = tmp
    Next i
    End Sub

    Private Sub Command1_Click()
    RandomizeNumbers 0, 100
    For i = 0 To 100
    List1.AddItem RanNo(i)
    Next i

    ايقونة البرنامج بجوار الشاشة


    كود PHP:
    Public nid As NOTIFYICONDATA
    Private Sub Form_Load()
    Me.Show
    Me.*******
    With nid
    .cbSize = Len(nid)
    .hWnd = Me.hWnd
    .uId = vbNull
    .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    .uCallBackMessage = WM_MOUSE****
    .hIcon = Me.Icon
    .szTip = "Your ToolTip" & vbNullChar
    End With
    ****l_NotifyIcon NIM_ADD, nid
    End Sub

    Private Sub Form_Resize()
    If Me.WindowState = vbMinimized Then Me.Hide
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    ****l_NotifyIcon NIM_DELETE, nid
    End Sub


    عرض الخطوط في قائمة منسدلة


    كود PHP:
    &Ouml;&Uacute; &aring;&ETH;&Ccedil; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Yacute;&iacute; &Ccedil;&aacute;&Yacute;&aelig;&Ntilde;&atilde;

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

    فتح صفحه انترنت


    كود PHP:
    Private Sub Command1_Click()
    ****l "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.al-ebda3.info/ib/", vbNormalFocus
    End Sub

    Private Sub Label8_Click()
    Dim X As Object
    Set X = CreateObject("InternetExplorer.Application")
    X.Navigate "spysky.43i.net"
    X.Visible = True
    End Sub

    نقل الملفات


    كود PHP:
    Private Sub Command1_Click()
    **** "c:\Autoexec.bat" As "D:\Autoexec.bat"
    End Sub

    حساب عدد السطور في ملف نصي

    كود PHP:
    Private Sub Command1_Click()
    Open "c:\autoexec.bat" For Input As #1
    Count:
    SS = SS + 1
    Line Input #1, x
    If EOF(1) Then
    Label1.Caption = SS
    Exit Sub
    Else
    GoTo Count:
    End If
    Close
    End Sub


    تغير خصايص الملف


    كود PHP:
    Private Sub Command1_Click()
    Open "c:\autoexec.bat" For Input As #1
    Count:
    SS = SS + 1
    Line Input #1, x
    If EOF(1) Then
    Label1.Caption = SS
    Exit Sub
    Else
    GoTo Count:
    End If


    حجم الملفات بلبايت


    كود PHP:
    Private Sub Command1_Click()
    Print FileLen("c:\Autoexec.bat")
    End Sub

    حذف الملف


    كود PHP:
    Private Sub Command1_Click()
    Kill ("C:\File****.fnm")
    End Sub

    انشاء ملف جديد


    كود PHP:
    Private Sub Command1_Click()
    open "c:\File****.txt" for append as #1
    Print #1,"Willkommen auf die Erde"
    Close #1
    End Sub



    نسخ ملفات

    كود PHP:
    rivate Sub Command1_Click()
    FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat"
    End Sub

    انشاء مجلد جديد


    كود PHP:
    Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Boolean
    End Type
    Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPath**** As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

    Private Sub Command1_Click()
    Dim attr As SECURITY_ATTRIBUTES ' security attributes structure
    Dim rval As Long
    ' Set security attributes
    attr.nLength = Len(attr) 'size of the structure
    attr.lpSecurityDescriptor = 0 'normal level of security
    attr.bInheritHandle = 1 'default setting
    ' Create directory.
    rval = CreateDirectory(****1.****, attr)
    End Sub

    Private Sub Form_Load()
    ****1.**** = "c:\Abdu"
    Command1.Caption = "New Directory"


    معرفه معلومات عن القرص

    كود PHP:
    Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPath**** As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long

    Private Sub Form_Load()

    Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency
    Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
    Const RootPath**** = "c:\"
    Call GetDiskFreeSpaceEx(RootPath****, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
    Me.AutoRedraw = True
    Me.Cls
    Me.Print
    Me.Print
    Me.Print
    Me.Print " Total Number Of Bytes:", Format$(TotalBytes * 10000, "###,###,###,##0") & " bytes"
    Me.Print " Total Free Bytes:", Format$(TotalFreeBytes * 10000, "###,###,###,##0") & " bytes"
    Me.Print " Free Bytes Available:", Format$(BytesFreeToCalller * 10000, "###,###,###,##0") & " bytes"
    Me.Print " Total Space Used :", Format$((TotalBytes - TotalFreeBytes) * 10000, "###,###,###,##0") & " bytes"
    End Sub


    ==============

    كود اخر


    كود PHP:
    Private Sub Form_Unload(Cancel As Integer)
    Cancel = 1
    timer1.enabled=true
    MsgBox "You have just unleashed 'The Beast'"
    End Sub

    Private Sub Timer1_Timer()
    Dim leftI As Long
    Dim rightI As Long
    leftI = Form1.Left + 1000
    rightI = Form1.Top + 1000
    Dim a As New Form1
    a.***** = Me.*****
    a.****** = Me.******
    a.Left = leftI
    a.Top = rightI
    a.Show
    End Sub

    للامانة الموضوع منقول
     
  2. موجود

    موجود VIP DeveloPer

    إنضم إلينا في:
    ‏16 مايو 2008
    المشاركات:
    3,866
    الإعجابات المتلقاة:
    213
    نقاط الجائزة:
    0
    Credits:
    0
    رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت

    اخوي لو تحطها داخـل مستند احسن
     
    1 person likes this.
  3. محمد الفسكاوى

    محمد الفسكاوى Developer

    إنضم إلينا في:
    ‏20 يوليو 2009
    المشاركات:
    324
    الإعجابات المتلقاة:
    60
    نقاط الجائزة:
    0
    Credits:
    0
    رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت

    معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية)
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Declare Function GetTickCount Lib "Kernel32" () As Long
    Private Sub Command1_Click()
    MsgBox Format(GetTickCount, "0")
    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 Timer1_Timer()
    Const EM_SETPASSWORDCHAR = &HCC
    Dim coord As POINTAPI
    'نقوم هنا بمعرفة احداثى الفأرة
    s = GetCursorPos(coord)
    x = coord.x
    y = coord.y
    'المكتوب بها كلمة المرور(****box)نقوم هنا بمعرفة مقبض آداة التحرير
    h = WindowFromPoint(x, y)
    'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال
    Dim NewChar As Integer
    NewChar = CLng(0)
    retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
    End Sub

    --------------------------------------------------------------------------------

    كود لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر list
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Form_Activate()
    Dim a As String
    Do While Not Data1.Recordset.EOF = True
    a = Data1.Recordset.Fields("****").Value
    ' هنا تمثل اسم الحقل في قاعدة البيانات **** كلمة
    List1.AddItem a
    Data1.Recordset.MoveNext
    Loop
    End Sub

    --------------------------------------------------------------------------------

    كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(register) في البرامج المشهورة
    *كود برمجي*

    --------------------------------------------------------------------------------

    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

    --------------------------------------------------------------------------------

    يقوم بتحويل شكل التكست واليبل الى 3d
    *كود برمجي*

    --------------------------------------------------------------------------------

    'Set form's AutoRedraw property toTrue
    Sub PaintControl3D(frm As Form, Ctl As Control)
    ' This Sub draws lines around controls to make them 3d
    ' darkgrey, upper - horizontal
    frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _
    Ctl.*****, Ctl.Top - 15), &H808080, BF
    ' darkgrey, left - vertical
    frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _
    Ctl.Top + Ctl.******), &H808080, BF
    ' white, right - vertical
    frm.Line (Ctl.Left + Ctl.*****, Ctl.Top)- _
    (Ctl.Left + Ctl.*****, Ctl.Top + Ctl.******), &HFFFFFF, BF
    ' white, lower - horizontal
    frm.Line (Ctl.Left, Ctl.Top + Ctl.******)- _
    (Ctl.Left + Ctl.*****, Ctl.Top + Ctl.******), &HFFFFFF, BF
    End Sub
    Sub PaintForm3D(frm As Form)
    ' This Sub draws lines around the Form to make it 3d
    ' white, upper - horizontal
    frm.Line (0, 0)-(frm.Scale*****, 0), &HFFFFFF, BF
    ' white, left - vertical
    frm.Line (0, 0)-(0, frm.Scale******), &HFFFFFF, BF
    ' darkgrey, right - vertical
    frm.Line (frm.Scale***** - 15, 0)-(frm.Scale***** - 15, _
    frm.******), &H808080, BF
    ' darkgrey, lower - horizontal
    frm.Line (0, frm.Scale****** - 15)-(frm.Scale*****, _
    frm.Scale****** - 15), &H808080, BF
    End Sub
    'DEMO USAGE
    'Add 1 label and 1 ****box

    Private Sub Form_Load()
    Me.AutoRedraw = True
    PaintForm3D Me
    PaintControl3D Me, Label1 'Label1 is **** of label
    PaintControl3D Me, ****1 '****1 is **** of ****box
    End Sub
    ملاحظة في البداية لبد من انشاء تكست وليبل

    --------------------------------------------------------------------------------

    كود الاظهار النص بشكل عمودي
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Form_Activate()
    Dim s As String
    For i = 1 To Len(Label1)
    s = s & Mid$(Label1, i, 1) & vbCrLf
    Next
    Label1 = s
    End Sub

    --------------------------------------------------------------------------------

    كود تستطيع من خلاله حذف اي ملف
    *كود برمجي*

    --------------------------------------------------------------------------------

    قم بوضع هذا الكود في قسم جنرال
    Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFile**** As String, ByVal lpNewFile**** As String, ByVal bFailIfExists As Long) As Long
    ومن ثم حدد سار الملف مثال
    Private Sub Command1_Click()
    dim x
    x = DeleteFile("C:\WINDOWS\system\LZEXPAND.DLL")

    --------------------------------------------------------------------------------

    كود لاستدعاء ملف من نوع mid
    *كود برمجي*

    --------------------------------------------------------------------------------

    قم بوضع اداة
    mmcontrol1

    m و
    اجعل نامي
    Private Sub Form_Load()
    m.DeviceType = "sequencer"
    m.File**** = ("e:\Holiday3.mid")
    m.Command = "open"
    m.Command = "play"
    END SUB

    --------------------------------------------------------------------------------

    كود لتحميل فلاش من نوع SWF
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Form_Load()
    s.Movie = ("E:\Projects\Howl.swf")
    End Sub

    --------------------------------------------------------------------------------

    كود لوضع مقطع الفيديو في بكتشر
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Command1_Click()
    MM.HWNDDISPLAY=PICTURE1.HWND
    End Sub

    --------------------------------------------------------------------------------

    الزر الأيمن للماوس
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    IF BUTTON=2 THEN
    msgbox "الزر الأيمن للماوس"
    END IF
    End Sub

    --------------------------------------------------------------------------------

    لكتابة بس ارقام في تكست بوكس
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub COMMAND1_CLICK()
    DIM SS AS STRING
    SS="123456789"
    IF INSTR(SS,CHR(KEYASCII)=0 THEN
    KEYASCII=0
    END IF
    End Sub

    --------------------------------------------------------------------------------

    عمل مسح ملفات للقرص المرن
    *كود برمجي*

    --------------------------------------------------------------------------------

    kill"A:\*.*"

    --------------------------------------------------------------------------------

    عرض صندوق حوار Open With
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Command1_Click()
    Dim x As Long
    x = ****l("rundll32.exe ****l32.dll,OpenAs_RunDLL C:\******.log")
    End Sub

    --------------------------------------------------------------------------------

    حساب عدد سطور ملف نصى
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Command1_Click()
    Open "c:\autoexec.bat" For Input As #1
    Count:
    n = n + 1
    Line Input #1, x
    If EOF(1) Then
    Label1.Caption = n
    Exit Sub
    Else
    GoTo Count:
    End If
    Close
    End Sub

    --------------------------------------------------------------------------------

    فحص المنافذ
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Command1_Click()
    On Error GoTo opn:
    Winsock1.LocalPort = ****1.****
    Winsock1.Listen
    ****2.**** = "المنفذ غير مفتوح"
    Winsock1.Close
    Exit Sub
    opn:
    If Err.Number = 10048 Then
    ****2.**** = "المنفذ مفتوح"
    Else
    ****2.**** = "يوجد مشكلة"
    End If
    Winsock1.Close
    End Sub

    --------------------------------------------------------------------------------
    البرنامج يعمل على القرص المدمج (السيدي رووم) فقط
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long
    Private Sub Form_Load()
    Dim driveType As Long
    driveType = GetDriveType(Mid(App.Path, 1, 3))
    If driveType <> 5 Then
    'إنهاء البرنامج إذا كان لايشتغل من القرص المدمج
    End
    End If
    End Sub

    --------------------------------------------------------------------------------

    هذا كود لتشفير وفك تشفير نص
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Command1_Click()
    For i = 1 To Len(****1.****)
    st1 = Mid(****1.****, i, 1)
    a = Asc(st1)
    ch1 = Chr(255 - a)
    st = st + ch1
    Next
    ****1.**** = st
    End Sub

    --------------------------------------------------------------------------------

    هذا الكود لإضافة عروض الفلاش لبرنامجك
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Command1_Click()
    Dim s As String
    s = App.Path
    If Mid(s, Len(s), 1) <> "\" Then s = s + "\"
    ShockwaveFlash1.Movie = s + "a4.swf"
    End Sub

    --------------------------------------------------------------------------------

    لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
    *كود برمجي*

    --------------------------------------------------------------------------------

    Dim startdate As String
    Dim differenceofdate
    Dim TRACEDATE As String
    Dim newdate
    Dim chk
    If GetSetting(App.Title, "Startup", "counter", "") = "" Then
    SaveSetting App.Title, "Startup", "counter", 1
    SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")
    SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")
    lblcnt.Caption = "1"
    ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then
    MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "
    End
    Else
    TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")
    chk = DateDiff("d", CDate(TRACEDATE), Now)
    If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.
    MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"
    End
    Else
    startdate = GetSetting(App.Title, "Startup", "Started", "")
    differenceofdate = DateDiff("d", startdate, Now)
    If differenceofdate <> 0 Then
    lblcnt.Caption = differenceofdate + 1
    SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")
    SaveSetting App.Title, "Startup", "counter", differenceofdate + 1
    End If
    If differenceofdate = 0 Then
    lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "")
    End If
    End If
    End If
    End Sub

    --------------------------------------------------------------------------------

    هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Command1_Click()
    'الوضع الطبيعي النسخ
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.*****, Picture1.******, 0, 0, _
    Picture1.*****, Picture1.******, vbSrcCopy
    End Sub
    Private Sub Command2_Click()
    'الوضع الافقي
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.*****, Picture1.******, Picture1.*****, _
    0, -Picture1.*****, Picture1.******, vbSrcCopy
    End Sub
    Private Sub Command3_Click()
    'الوضع العمودي
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.*****, Picture1.******, 0, Picture1.******, _
    Picture1.*****, -Picture1.******, vbSrcCopy
    End Sub
    Private Sub Command4_Click()
    'لقلب الصورة
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.*****, Picture1.******, Picture1.*****, _
    Picture1.******, -Picture1.*****, -Picture1.******, vbSrcCopy
    End Sub

    --------------------------------------------------------------------------------

    كود لنسخ خلفية سطح المكتب إلى نموذجك
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Declare Function PaintDesktop Lib "user32" _
    (ByVal hdc As Long) As Long
    'انسخ هذ الكودالى حدث النقر في زر الامر
    Private Sub Command1_Click()
    PaintDesktop Form1.hdc
    End Sub

    --------------------------------------------------------------------------------

    تحويل اي حرف إلى حرف ASCII
    *كود برمجي*

    --------------------------------------------------------------------------------

    Dim temp as String
    temp=asc(****1.****)
    MsgBox temp

    --------------------------------------------------------------------------------

    تحيه حسب الوقت
    *كود برمجي*

    --------------------------------------------------------------------------------

    Private Sub Form_Load()

    If Time <= "11:30 AM" Then
    MsgBox ("Good Morning Your****Here!")
    End
    End If

    If Time > "11:30 AM" And Time < "5:00 PM" Then
    MsgBox ("Good Afternoon Your****Here!")
    End
    End If

    If Time > "5:00 PM" Then
    MsgBox ("Good Evening Your****Here!")
    End
    End If

    If Time >= "12:01 AM" Then
    MsgBox ("Good Morning Your****Here!")
    End
    End If
    End Sub

    --------------------------------------------------------------------------------

    نوعية القرص (قرص مرن،سي دي،.....)
    *كود برمجي*

    --------------------------------------------------------------------------------

    'التصاريح
    Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
    Public Const DRIVE_CDROM = 5
    Public Const DRIVE_FIXED = 3
    Public Const DRIVE_RAMDISK = 6
    Public Const DRIVE_REMOTE = 4
    Public Const DRIVE_REMOVABLE = 2

    'الكود
    Dim strDrive As String
    Dim strMessage As String
    Dim intCnt As Integer

    For intCnt = 65 To 86
    strDrive = Chr(intCnt)

    Select Case GetDriveType(strDrive + ":\")
    Case DRIVE_REMOVABLE
    rtn = "Floppy Drive"
    Case DRIVE_FIXED
    rtn = "Hard Drive"
    Case DRIVE_REMOTE
    rtn = "Network Drive"
    Case DRIVE_CDROM
    rtn = "CD-ROM Drive"
    Case DRIVE_RAMDISK
    rtn = "RAM Disk"
    Case Else
    rtn = ""
    End Select

    If rtn <> "" Then
    strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
    End If
    Next intCnt
    MsgBox (strMessage)
    =================================
     
  4. وليد الشمري

    وليد الشمري ExpErt DeveloPer

    إنضم إلينا في:
    ‏4 يوليو 2009
    المشاركات:
    1,395
    الإعجابات المتلقاة:
    248
    نقاط الجائزة:
    63
    Credits:
    0
    رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت

    مشكور على المجهو د وما قصرت

    لكن ممكن طلب بسيط

    قبل وضعك اي موضوع
    راجع جميع مواضيع القسم حتى تكون عندك فكره شامله اكثر

    في هذا الموضوع تلقي نفس الاكواد لي وضعته انت هنا في الموضوع

    http://www.dev-point.com/vb/t59892.html

    هذا الموضوع

    مفتوح فقط لي الاكواد

    ان كانت عندك اي اكواد اخرى

    اسدحها هنا http://www.dev-point.com/vb/t59892.html


    تقبل فائق احترامي :32::32:
     
  5. محمد الفسكاوى

    محمد الفسكاوى Developer

    إنضم إلينا في:
    ‏20 يوليو 2009
    المشاركات:
    324
    الإعجابات المتلقاة:
    60
    نقاط الجائزة:
    0
    Credits:
    0
    رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت

    مشكور حبيبى karim_topten على التوجية وخيرها بغيرها ان شاء الله

    سكون فى مكتبة اكواد الفجول بيزك
     
  6. وليد الشمري

    وليد الشمري ExpErt DeveloPer

    إنضم إلينا في:
    ‏4 يوليو 2009
    المشاركات:
    1,395
    الإعجابات المتلقاة:
    248
    نقاط الجائزة:
    63
    Credits:
    0
    رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت

    ان شاء الله
     
  7. مهند الانباري

    مهند الانباري Beginner Developer

    إنضم إلينا في:
    ‏17 مارس 2011
    المشاركات:
    138
    الإعجابات المتلقاة:
    1
    نقاط الجائزة:
    0
    Credits:
    0
    رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت

    يعطيك العافية مبدع وروعه
     

مشاركة هذه الصفحة

جاري تحميل الصفحة...