1. VeRoS_Dz

    VeRoS_Dz Developer

    الأنتساب:
    ‏10 أغسطس 2012
    المشاركات:
    37
    الإعجابات المتلقاة:
    1
    نقاط الجائزة:
    8
    الوظيفة:
    VeRoS_Dz
    الإقامة:
    VeRoS_Dz
    [​IMG]

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

    موضوع اليوم مكتبة اكواد فيجول بيسك | Visual Basic Codes

    اتصال تليفوني

    كود PHP:
    Private Sub Command1_Click()
    On Error GoTo eror_non
    Dim Number
    $, Temp$
    Call_n.Caption "الإتصال بـ / " Trim(Text1)

    Number$ = Trim(Text1.Text)
    If 
    Number$ = "" Then Exit Sub
    Command1
    .Enabled False
    Command2
    .Enabled True
    Status 
    "جاري الإتصال بـ " Number$

    Dial Number$
    eror_non:
    End Sub
    Private Sub Dial(Number$)
    On Error GoTo error_1
    Dim DialString
    $, FromModem$, dummy
    Dim msg1 
    As String
    Dim msg2 
    As String
    Dim response 
    As Integer
    Dim mod_com 
    As Integer

    mod_com 
    2

    DialString
    $ = "ATDT" Number$ + ";" vbCr
    MSComm1
    .CommPort mod_com
    MSComm1
    .Settings "9600,N,8,1"

    On Error Resume Next
    MSComm1
    .PortOpen True
    If Err Then
    Beep
    Screen
    .MousePointer 0
    msg1 
    " COM تعذر الوصول إلى جهاز المودم أو مخرج الإتصال " mod_com
    msg2 
    "للمساعدة أنظر دليل رسائل الأخطاء "
    MsgBox msg116msg2
    Status 
    ""
    DialButton.Enabled True
    CancelButton
    .Enabled False
    Exit Sub
    End 
    If

    MSComm1.InBufferCount 0

    MSComm1
    .Output DialString$

    Do
    dummy DoEvents()
    If 
    MSComm1.InBufferCount Then
    FromModem
    $ = FromModem$ + MSComm1.Input
    If InStr(FromModem$, "OK"Then

    CancelButton
    .Enabled False
    Status 
    "تم الإتصال بـ " Number$
    Beep
    response 
    MsgBox("اختر موافق لتحويل المكالمة للهاتف(ارفع السماعة أولا) أو الغاء الامر لإنهاء المكالمة"1)
    If 
    response 1 Then '== موافق
    DialButton.Enabled = True
    CancelButton.Enabled = False
    Status = ""
    Exit Do
    Else
    CancelFlag = False
    Status = ""
    DialButton.Enabled = True
    CancelButton.Enabled = False
    Exit Do
    End If
    Exit Do
    End If
    End If

    If CancelFlag Then
    CancelFlag = False
    Exit Do
    End If
    Loop

    MSComm1.Output = "ATH" + vbCr

    MSComm1.PortOpen = False
    Exit Sub
    '
    ---------------------------------------
    error_1:
    Beep
    Screen
    .MousePointer 0
    msg1 
    " تعذر الوصول إلى جهاز المودم، المودم تحت استخدام برنامج آخر!،أعد تشغيل البرنامج و كرر المحاولة"
    msg2 "للمساعدة أنظر دليل رسائل الأخطاء "
    MsgBox msg116msg2
    Status 
    ""
    DialButton.Enabled True
    CancelButton
    .Enabled False
    Exit Sub
    End Sub

    [​IMG]

    إجراء اتصال تليفوني

    كود PHP:
    Private Declare Function tapiRequestMakeCallLib "TAPI32.DLL" (ByVal DestAddress$, ByVal AppName$, ByVal CalledParty$, ByVal Comment$)
    Private Const 
    TAPIERR_NOREQUESTRECIPIENT = -2&
    Private Const 
    TAPIERR_REQUESTQUEUEFULL = -3&
    Private Const 
    TAPIERR_INVALDESTADDRESS = -4&


    Private 
    Sub cmdDial_Click()
        
    Dim buff As String
        Dim nResult 
    As Long

        
    'Invoke tapiRequestMakeCall. If tapiRequestMakeCall returns 0, the
        '
    request has been acceptedIt is up to the call manager application
        
    'to do any further work. The second-to-last argument should be
        '
    changed to be the name of the person you are dialing.
        
    nResult tapiRequestMakeCall&(Trim$(txtNumber), CStr(Caption), "Test Dial""")
        
    'Display message if error
        If nResult <> 0 Then
            buff = "Error dialing number : "
            Select Case nResult
                Case TAPIERR_NOREQUESTRECIPIENT
                    buff = buff & "No Windows Telephony dialing application is running and none could be started."
                Case TAPIERR_REQUESTQUEUEFULL
                    buff = buff & "The queue of pending Windows Telephony dialing requests is full."
                Case TAPIERR_INVALDESTADDRESS
                    buff = buff & "The phone number is not valid."
                Case Else
                    buff = buff & "Unknown error."
            End Select
            MsgBox buff
        End If
    End Sub

    Private Sub cmdExit_Click()
        Unload Me
    End Sub

    Private Sub Form_Load()
        Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
        EnableDial
    End Sub

    Private Sub txtNumber_Change()
        EnableDial
    End Sub

    Private Sub EnableDial()
        cmdDial.Enabled = Len(Trim$(txtNumber)) > 0
    End Sub

    [​IMG]

    أرسل رسالة للجوالSMS

    كود PHP:
    Dim SMS As Simplewire.SMS 
    Dim carrier 
    As Simplewire.SMSCarrier 
    Dim Index 
    As Integer 
    ' instantiate the the request 
    Set SMS = New Simplewire.SMS 
    send off a carrier list request 
    SMS
    .CarrierListSend 
    ' first off, we need to check if the req
    '     
    uest was a success 
    If SMS.Success False Then 
    ' display the error de******ion 
    MsgBox SMS.ErrorDesc & " " & SMS.ErrorCode, vbCritical, "Carrier List Error" 
    kill the pager interfaces 
    Set SMS 
    Nothing 
    ' stop the program 
    End 
    otherwisewe have a valid response 
    Else 
    ' resize PagerService array to make a pe
    '     
    rfect fit 
    ReDim SMSCarrierID
    (SMS.CarrierList.Count
    ReDim SMSCarrierTextMaxLength(SMS.CarrierList.Count
    ' init the integer 
    Index = 0 
    loop until the next service doesnt exi
    '     st 


    For Each carrier In SMS.CarrierList 
        ' 
    set the new item on the combo box and 
        
    '     set the subtitle in the 
        .CarrierList.AddItem carrier.Title & " " & carrier.Subtitle 
        ' 
    set the service id for the global serv
        
    '     ice id array 
        SMSCarrierID(Index) = carrier.ID 
        SMSCarrierTextMaxLength(Index) = carrier.TextMaxLength 
        ' 
    increment the index 
        Index 
    Index 
    Next 
    ' init the list 
    .CarrierList.ListIndex = 0 
    End If 
    kill the sms object 
    Set SMS 
    Nothing

    [​IMG]

    استقبال مكالمة هاتفية

    كود PHP:
    Private Sub Form_Load()
    MSComm1.Settings "9600,N,8,1"
    ' لوب للتشييك على عشرة منافذ وإستخراج رقم منفذ المودوم الصحيح

    For i = 1 To 10
    MSComm1.CommPort = i

    On Error GoTo N
    MSComm1.PortOpen = True

    N:
    If MSComm1.PortOpen = True Then
    Exit For
    End If

    Next

    End Sub

    Private Sub MSComm1_OnComm()

    If MSComm1.CommEvent Then

    MsgBox " وصول إتصال لك "

    End If

    End Sub 

    [​IMG]

    مراقبة أحد منافذ الجهاز

    كود PHP:
    Private Sub Command1_Click()
    'لجعل البرنامج في إنتظار المتصل
    Winsock1.LocalPort = Text1.Text
    Winsock1.Listen
    Command1.Enabled = False
    Label1.Caption = "البرنامج في إنتظار متصل"
    End Sub
    Private Sub Command2_Click()
    '
    لتوقف البرنامج عن الإنتظار
    Winsock1
    .Close
    Command1
    .Enabled True
    Label1
    .Caption "توقف عن الإنتظار"
    End Sub
    Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
    'عندما يتم اٌتصال من قبل أي برنامج إتصال خارجي
    '
    العداد الذي يحسب عدد مرات الدخول
    Label4
    .Caption Label2.Caption 'ليضيف في القوائم بيانات المخترقList1.AddItem Winsock1.LocalHostNameList2.AddItem Winsock1.LocalIPList3.AddItem Label2.CaptionLabel1.Caption = "تم الإتصال بالبرنامج"
    Beep
    End Sub

    [​IMG]

    معرفة رقم المنفذ الخاص بالمودم

    كود PHP:
    Private Sub Form_Load()
        
    MSComm1.Settings "9600,N,8,1"
        ' لوب للتشييك على عشرة منافذ وإستخراج رقم منفذ المودوم الصحيح
        
        For i = 1 To 10
        MSComm1.CommPort = i
        
        On Error GoTo N
        MSComm1.PortOpen = True
        
    N:
        If MSComm1.PortOpen = True Then
        Exit For
        End If
        Next
    End Sub

    Private Sub MSComm1_OnComm()
        If MSComm1.CommEvent Then
        MsgBox " وصول إتصال لك "
        End If
    End Sub
    الرقم التسلسلي للوحة الام

    كود PHP:
    Option Explicit

    'نكتب في الموديول
    Private Declare Sub GetMem1 Lib "msvbvm50.dll" (ByVal MemAddress As Long, var As Byte)
    Private Function GetBIOSDate() As String
        Dim p As Byte, MemAddr As Long, sBios As String
        Dim i As Integer
        MemAddr = &HFEC71
        For i = 0 To 25
            Call GetMem1(MemAddr + i, p)
            sBios = sBios & Chr$(p)
        Next i
        GetBIOSDate = sBios
    End Function

    '
    وفي الأمر
    Private Sub Command1_Click()
    MsgBox GetBIOSDate
    End Sub

    [​IMG]

    لإطفاء وتشغيل الشاشة

    كود PHP:
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As LongByVal wMsg As LongByVal wParam As LonglParam As Any_
    As Long
    Const WM_SYSCOMMAND = &H112
    Const SC_MONITORPOWER = &HF170

    ثم اكتب هذا الكود لإطفاء الشاشة 
    :

    SendMessage Me.hwndWM_SYSCOMMANDSC_MONITORPOWER2&

    أما لتشغيل الشاشة فاكتب الكود التالي :

    SendMessage Me.hwndWM_SYSCOMMANDSC_MONITORPOWER, -1

    [​IMG]

    لفتح الـ CD-ROM وإغلاقه

    كود PHP:
    Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
    ByVal lpstrCommand 
    As StringByVal lpstrReturnString As String_
    ByVal uReturnLength 
    As LongByVal 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

    [​IMG]

    معرفة بعض المعلومات عن المعالج

    كود PHP:
    Private Type SYSTEM_INFO
        dwOemID 
    As Long
        dwPageSize 
    As Long
        lpMinimumApplicationAddress 
    As Long
        lpMaximumApplicationAddress 
    As Long
        dwActiveProcessorMask 
    As Long
        dwNumberOfProcessors 
    As Long
        dwProcessorType 
    As Long
        dwAllocationGranularity 
    As Long
        wProcessorLevel 
    As Integer
        wProcessorRevision 
    As Integer
        End Type

    Private Type OSVERSIONINFO
        dwOSVersionInze 
    As Long
        dwMajorVersion 
    As Long
        dwMinorVersion 
    As Long
        dwBuildNumber 
    As Long
        dwPlatformId 
    As Long
        szCSDVersion 
    As String 128 ' Maintenance string For PSS usage
        End Type

    Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
    Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
    Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
        
        Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
        Private Const PROCESSOR_INTEL_386 = 386
        Private Const PROCESSOR_INTEL_486 = 486
        Private Const PROCESSOR_INTEL_PENTIUM = 586
        Private Const PROCESSOR_LEVEL_80386 As Long = 3
        Private Const PROCESSOR_LEVEL_80486 As Long = 4
        Private Const PROCESSOR_LEVEL_PENTIUM As Long = 5
        Private Const PROCESSOR_LEVEL_PENTIUMII As Long = 6
        Private Const VER_PLATFORM_WIN32_NT = 2
        Private Const VER_PLATFORM_WIN32_WINDOWS = 1


    Private Type udtCPU
        lClockSpeed As Variant
        lProcType As Integer
        strProcLevel As String
        strProcRevision As String
        lNumberOfProcessors As Long
        End Type


    Private Enum eVersion
        eWindowsNT = 1
        eWindows95_98 = 2
        eUnknown = 3
    End Enum


    Private Function GetCPUInfo(ptCPUInfo As udtCPU)
        Dim tSYS As SYSTEM_INFO
        Dim intProcType As Integer
        Dim strProcLevel As String
        Dim strProcRevision As String
        Call GetSystemInfo(tSYS)


        Select Case tSYS.dwProcessorType
            Case PROCESSOR_INTEL_386: intProcType = 386
            Case PROCESSOR_INTEL_486: intProcType = 486
            Case PROCESSOR_INTEL_PENTIUM: intProcType = 586
        End Select


    Select Case tSYS.wProcessorLevel
        Case PROCESSOR_LEVEL_80386: strProcLevel = "Intel 80386"
        Case PROCESSOR_LEVEL_80486: strProcLevel = "Intel 80486"
        Case PROCESSOR_LEVEL_PENTIUM: strProcLevel = "Intel Pentium"
        Case PROCESSOR_LEVEL_PENTIUMII: strProcLevel = "Intel Pentium Pro or Pentium II"
    End Select
    strProcRevision = "Model " & HiByte(tSYS.wProcessorRevision) & ", Stepping " & LoByte(tSYS.wProcessorRevision)


    With ptCPUInfo
    .lClockSpeed = GetCPUSpeed
    .lNumberOfProcessors = tSYS.dwNumberOfProcessors
    .lProcType = intProcType
    .strProcLevel = IIf(strProcLevel = "", "None", strProcLevel)
    .strProcRevision = IIf(strProcRevision = "", "None", strProcRevision)
    End With
    End Function


    Private Function GetVersion() As eVersion
        Dim os As OSVERSIONINFO
        os.dwOSVersionInze = Len(os)


        If GetVersionEx(os) Then


            If os.dwPlatformId = VER_PLATFORM_WIN32_NT Then
                GetVersion = eWindowsNT
            Else
                GetVersion = eWindows95_98
            End If
        Else
            GetVersion = eUnknown
        End If
    End Function


    Private Function HiByte(ByVal wParam As Integer) As Byte
        HiByte = (wParam And &HFF00&) \ (&H100)
    End Function


    Private Function LoByte(ByVal wParam As Integer) As Byte
        LoByte = wParam And &HFF&
    End Function


    Private Function GetCPUSpeed() As Variant
        Dim hKey As Long
        Dim lClockSpeed As Long
        Dim strKey As String


        If GetVersion = eWindowsNT Then
            strKey = "HARDWARE\DE******ION\System\CentralProcessor\0"
            Call RegOpenKey(HKEY_LOCAL_MACHINE, strKey, hKey)
            Call RegQueryValueEx(hKey, "~MHz", 0, 0, lClockSpeed, 4)
            Call RegCloseKey(hKey)
            GetCPUSpeed = lClockSpeed
        Else
            GetCPUSpeed = "Could Not be determined"
        End If
    End Function

    '
    وفي زر الأمر نكتب

    Private Sub Command1_Click()
        
    Dim tCPU As udtCPU
        Call GetCPUInfo
    (tCPU)
        
    List1.AddItem "CPU Type: " tCPU.lProcType
        List1
    .AddItem "Number ofCPUs:" tCPU.lNumberOfProcessors
        List1
    .AddItem "CPU Level: " tCPU.strProcLevel
        List1
    .AddItem "CPU Revision:" tCPU.strProcRevision
        List1
    .AddItem "CPU Speed (Approx): " tCPU.lClockSpeed
    End Sub

    [​IMG]

    معرفة تاريخ برنامج البايوس

    كود PHP:
    Private Declare Sub GetMem1 Lib "msvbvm50.dll" (ByVal MemAddress As Long, var As Byte)

    Private Function 
    GetBIOSDate() As String
    Dim p 
    As ByteMemAddr As LongsBios As String
    Dim i 
    As Integer

    MemAddr 
    = &HFFFF5
    For 0 To 7
    Call GetMem1
    (MemAddr ip)
    sBios sBios Chr$(p)
    Next i
    GetBIOSDate 
    sBios
    End 
    Function

    Private 
    Sub Form_Load()
    MsgBox "The Bios date: " GetBIOSDate
    End Sub
    لنا عوده )4:"
     
  2. VeRoS_Dz

    VeRoS_Dz Developer

    الأنتساب:
    ‏10 أغسطس 2012
    المشاركات:
    37
    الإعجابات المتلقاة:
    1
    نقاط الجائزة:
    8
    الوظيفة:
    VeRoS_Dz
    الإقامة:
    VeRoS_Dz
    رد: مكتبة اكواد فيجول بيسك Visual Basic Codes

    كود الخروج من البرنامج [ هل تريد الخروج من البرنامج ] [ نعم أو لأ ]

    كود PHP:
    private sub command1_click()
    msgbox("آنت الان تحاول الخروج من البرنامج هل انت متاكد من هذا الرغبـه"vbyesno vbinformation"تنـبيهً")
    select case d
    case vbyes
    end
    end select
    end sub 
    [​IMG]

    كـود اضهار اسم الجهاز واي بي الجهاز الخاص بك

    كود PHP:
    dim strname as string
    strip 
    winsock1.localip 'captures ip address and stores it
    strname = winsock1.localhostname '
    captures host name and stores
    msgbox 
    "your ip address is: " strip vbcrlf vbcrlf _
    "your hostname is: " ucase(strname'seperates the 2 in a 
    [​IMG]

    كـود افراغ سلة المحذوفات

    كود PHP:
    ضع هذا الكود في العام general او موديول module
     
    private declare function shemptyrecyclebin lib "****l32.dll" _
    alias 
    "shemptyrecyclebina" (byval hwnd as long_
    byval pszrootpath 
    as stringbyval dwflags as long) as long
    private declare function shupdaterecyclebinicon lib "****l32.dll" () as long
    \\\
     
    في الكومـند
     
    لافراغ سلة المحذوفات 
    :
    Shemptyrecyclebin me.hwndvbnullstring0
     
    للتحديث بعد افراغ البيانات 
    :
    Shupdaterecyclebinicon 
    [​IMG]

    كـود تغيير الصفحه الرئيسيه الخاصه بك في المتصفح

    كود PHP:
    في جزء التصريحات العام "general"
    \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    private declare function 
    regclosekey lib "advapi32.dll" (byval hkey as long) as long
    private declare function regcreatekey lib "advapi32.dll" alias "regcreatekeya" (byval hkey as longbyval lpsubkey as stringphkresult as long) as long
    private declare function regsetvalueex lib "advapi32.dll" alias "regsetvalueexa" (byval hkey as longbyval lpvaluename as stringbyval reserved as longbyval dwtype as longlpdata as anybyval cbdata as long) as long
    private const reg_sz 1
    private const hkey_current_user = &h80000001
    public sub savestring(hkey as longpath as stringname as stringdata as string)
    dim keyhandle as long
    dim r 
    as long
    regcreatekey(hkeypathkeyhandle)
    regsetvalueex(keyhandlename0reg_szbyval datalen(data))
    regclosekey(keyhandle)
    end sub
    public sub setstartpage(url as string)
    call savestring(hkey_current_user"software\microsoft\internet explorer\main""start page"url)
    end sub
     
    \\\\\\\\\\\\\\\\\\\\\\\\\
    \\\\\ 
    في الزر \\\\\\\
    private 
    sub command1_click()
    setstartpage ("www.dev-point.com")
    end sub 
    [​IMG]

    كـود .. الانتقال الى الموقع

    كود PHP:
    dim x as object
    set x 
    createobject("internetexplorer.application")
    x.navigate "www.google.com"
    x.visible true 
    [​IMG]

    خلفيه روعـه أنصحكم فيهـآ

    كود PHP:
    الجنرال .
    Private declare function 
    setlayeredwindowattributes lib "user32.dll" (byval hwnd as longbyvalcrkey as longbyval balpha as bytebyval dwflags as long) as boolean
    private declare function setwindowlong lib "user32" alias "setwindowlonga" (byval hwnd as longbyval nindex as longbyval dwnewlong as long) as long
    private declare function getwindowlong lib "user32" alias "getwindowlonga" (byval hwnd as longbyval nindex as long) as long
    const lwa_alpha 2
    const gwl_exstyle = (-20)
    const 
    ws_ex_layered = &h80000
    end sub
    الفورم لود
     
    private sub form_load()
    setwindowlong hwndgwl_exstylegetwindowlong(hwndgwl_exstyle) or ws_ex_layered
    setlayeredwindowattributes hwnd
    0128lwa_alpha
    end sub 
    [​IMG]

    كود افراغ حقول التكسـت

    كود PHP:
    Dim i As Integer
    For 0 To Me.Controls.Count 1
    If TypeOf Me.Controls(iIs TextBox Then
    Me
    .Controls(i).Text ""
    End If
    Next 
    [​IMG]

    كـود دائره حمراء حول مؤشر الماوس [ نضع هذا الكود في الفورم ]

    كود PHP:
    Private Sub Form_MouseMove(Button As IntegerShift As Integer_
    As SingleAs Single)
    Me.Cls
    Circle 
    (XY), 100vbRed
    End Sub 
    [​IMG]

    كـود اضهار واخفاء الصوره [ ] حلو الكود ذا

    اول شي نضيف صوره من اداهـ [ Image1 ]

    بعد كذا نضيف [ Command2 + Command1 ]

    الاول نسـميه .. اضهار والثاني نسيمه اخفاء
    هذا الكود نضعه في الزر الاول Command1

    كود PHP:
    Private Sub Command1_Click()
    Image1.Visible True
    End Sub
    وهذا الكود في الـزر الثاني Command2

    كود PHP:
    Private Sub Command2_Click()
    Image1.Visible False
    End Sub  
    الاول اخفاء والثاني اضهار الصوره

    هذا الكود لنسخ من التكسسـت
    نفس الكود الي استعملته في برنامج [ لتوبيكات ]

    نضع هذا الكود في الزر

    كود PHP:
    With Text1
    .SelStart 0
    .SelLength Len(.Text)
    Clipboard.Clear
    .SetFocus
    Clipboard
    .SetText .Text
    End With
     
    MsgBox 
    "تم نسخ التوبيك", , "عملية النسخ" 
    لاكن لاتنساء ان تغير الحقل المراد النسخ منه Text1
    < يعني ينسـخ النص الموجود داخل الحقل رقم واحد >

    [​IMG]

     
  3. VeRoS_Dz

    VeRoS_Dz Developer

    الأنتساب:
    ‏10 أغسطس 2012
    المشاركات:
    37
    الإعجابات المتلقاة:
    1
    نقاط الجائزة:
    8
    الوظيفة:
    VeRoS_Dz
    الإقامة:
    VeRoS_Dz
    رد: مكتبة اكواد فيجول بيسك Visual Basic Codes

    بااااك .aًُoً.

    تفعيل و تعطيل زر الإغلاق في النوافذ بالكود

    في قسم التصريحات العامة

    كود PHP:
    private declare function getsystemmenu lib "user32" (byval hwnd _
    as longbyval brevert as boolean) as long
    private declare function getmenuitemcount lib "user32" (byval _
    hmenu 
    as long) as long
    private declare function removemenu lib "user32" (byval _
    hmenu 
    as longbyval nposition as longbyval wflags as long_
    as long
    private declare function drawmenubar lib "user32" (byval hwnd as long) as long
    private const mf_byposition = &h400&
    private const 
    mf_remove = &h1000&
    public 
    sub disableclose(frm as formoptional _
    disable 
    as boolean true)
    'setting disable to false disables the 'x',
    '
    otherwiseits reset
    dim hmenu 
    as long
    dim ncount 
    as long
    if disable then
    hmenu 
    getsystemmenu(frm.hwndfalse)
    ncount getmenuitemcount(hmenu)
    call removemenu(hmenuncount 1mf_remove or _
    mf_byposition
    )
    call removemenu(hmenuncount 2mf_remove or _
    mf_byposition
    )
    drawmenubar frm.hwnd
    else
    getsystemmenu frm.hwndtrue
    drawmenubar frm
    .hwnd
    end 
    if
    end sub 
    أما في زر التفعيل )2:"

    كود PHP:
    call disableclose(mefalse
    و في زر التعطيل

    كود PHP:
    call disableclose(metrue)
    [​IMG]

    تغيير اسم الفورم من الفورم

    نضيف هذا الكود في حدث الفورم

    كود PHP:
    form1.caption "IQ-TeaM" 
    [​IMG]

    كـود حلو ذا امر فتح السيدي روم
    في الجنـرال

    كود PHP:
    private declare function mcisendstring lib "winmm.dll" alias "mcisendstringa" _
    byval lpstrcommand 
    as stringbyval lpstrreturnstring as string_
    byval ureturnlength 
    as longbyval 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
    [​IMG]

    في الزر

    كود PHP:
    private sub command1_click()
    private 
    sub emptyrecyclebin()
    end sub  
    [​IMG]

    كــٍوٍدٍ لوضع الموقع في المفـضـله

    كود PHP:
    في المديـل
    private declare function shgetspecialfolderlocation _
    lib 
    "****l32.dll" (byval hwndowner as long_
    byval nfolder 
    as special****lfolderids_
    pidl 
    as long) as long

    private declare function shgetpathfromidlist _
    lib 
    "****l32.dll" alias "shgetpathfromidlista" _
    (byval pidl as long_
    byval pszpath 
    as string) as long

    private declare sub cotaskmemfree lib "ole32.dll" _
    (byval pv as long)

    public 
    enum special****lfolderids
    csidl_desktop 
    = &h0
    csidl_internet 
    = &h1
    csidl_programs 
    = &h2
    csidl_controls 
    = &h3
    csidl_printers 
    = &h4
    csidl_personal 
    = &h5
    csidl_favorites 
    = &h6
    csidl_startup 
    = &h7
    csidl_recent 
    = &h8
    csidl_sendto 
    = &h9
    csidl_bitbucket 
    = &ha
    csidl_startmenu 
    = &hb
    csidl_desktopdirectory 
    = &h10
    csidl_drives 
    = &h11
    csidl_network 
    = &h12
    csidl_nethood 
    = &h13
    csidl_fonts 
    = &h14
    csidl_templates 
    = &h15
    csidl_common_startmenu 
    = &h16
    csidl_common_programs 
    = &h17
    csidl_common_startup 
    = &h18
    csidl_common_desktopdirectory 
    = &h19
    csidl_appdata 
    = &h1a
    csidl_printhood 
    = &h1b
    csidl_altstartup 
    = &h1d
    csidl_common_altstartup 
    = &h1e
    csidl_common_favorites 
    = &h1f
    csidl_internet_cache 
    = &h20
    csidl_
    ******= &h21
    csidl_history 
    = &h22
    end enum


    public sub addfavorite(sitename as stringurl as string)
    dim pidl as long
    dim intfile 
    as integer
    dim strfullpath 
    as string

    on error 
    goto goodbye

    intfile 
    freefile
    strfullpath 
    space(255)


    if 
    shgetspecialfolderlocation(0csidl_favoritespidl) = 0 then
    if pidl then
    if shgetpathfromidlist(pidlstrfullpaththen
    if instr(1strfullpathchr(0)) then
    strfullpath 
    mid(strfullpath1_
    instr
    (1strfullpathchr(0)) - 1)
    end if

    if 
    right(strfullpath1) <> "\" then
    strfullpath = strfullpath & "
    \"
    end if

    strfullpath = strfullpath & sitename & "
    .url"
    open strfullpath for output as #intfile
    print #intfile, "
    [internetshortcut]"
    print #intfile, "
    url=" & url
    close #intfile

    end if
    cotaskmemfree pidl
    end if
    end if

    goodbye:

    End sub
    في الزر
    private sub command1_click()
    addfavorite "
    IQ-TEAM", "http://www.iq-team.org/vb"
    end sub
    النـجوم حطـو كلمه
    s h e l l 32

    [​IMG]

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

    كود PHP:
    Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As LongByVal hWndInsertAfter As LongByVal X As LongByVal Y As LongByVal cx As LongByVal cy As LongByVal wFlags As Long
    ثم ضع على حدث تحميل الفورم Form Load

    كود PHP:
    Timer1.Interval 1
    ثم نضيف اداة التايمر

    وعلى timer1 ونضيف في حدث التايمر هذا الكود

    كود PHP:
    SetWindowPos Form1.hwnd, -10000
    [​IMG]

    كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك)

    كود PHP:
    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 
    If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل

    هنا رقم 3 نقوم بتغييره الى عدد المرات التي يقوم برنامجك بتشغيل فقط [ اي بعد ثلاث مرات من تشغيل برنامج بعدها تضهر رسال للمستخدم [ نتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية ]

    [​IMG]

    كود منع الزر الايمن بالماوس في برنامج
    نضـع هذا الكود في الفورم في حدث .. MouseDown

    كود PHP:
    Private Sub Form_MouseDown(Button As IntegerShift As IntegerAs SingleAs Single)
    If 
    Button 2 Then
    MsgBox 
    "ممـنوع استخدام الزر الايمن بالماوس"
    End If
    End Sub 
    [​IMG]
     
  4. VeRoS_Dz

    VeRoS_Dz Developer

    الأنتساب:
    ‏10 أغسطس 2012
    المشاركات:
    37
    الإعجابات المتلقاة:
    1
    نقاط الجائزة:
    8
    الوظيفة:
    VeRoS_Dz
    الإقامة:
    VeRoS_Dz
    رد: مكتبة اكواد فيجول بيسك Visual Basic Codes

    باااااااك

    كود لمنع المستخدم من ادخال في مربع النص غير ارقام

    كود PHP:
    Private Sub text1_keypress(keyascii As Integer)
    If (
    keyascii 48 Or keyascii 57Then keyascii 0
    End Sub 
    نضع هذا الكود في [ صندوق النص في الحدث keypress ]

    [​IMG]

    كود لمعرفة عدد الاسطر في مربع النص [ صندوق النص ]

    في التصاريح العامه

    كود PHP:
    Option Explicit
    في الزر
    command1

    كود PHP:
    Private Sub Command1_Click()
    Dim X() As String
    Split(Text1.TextvbNewLine)
    MsgBox UBound(X) + 1
    End Sub  
    [​IMG]

    فتح الـ CD-ROM وإغلاقه

    كود PHP:
    Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As StringByVal lpstrReturnString As StringByVal uReturnLength As LongByVal 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
    [​IMG]

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

    كود 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:
    Dim WSH As Object
    Set WSH 
    CreateObject("Wscript.****l")
    WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoDrives"4"REG_DWORD"
    [​IMG]

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

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

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As StringByVal lpWindowName As String) As Long

    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As LongByVal hWndInsertAfter As LongByVal X As LongByVal y As LongByVal cx As LongByVal cy As LongByVal wFlags As Long) As Long
    ' ضع هذا الكود في الفورم

    كود PHP:
    Private Sub Command1_Click()
    Dim Task As Long
    Task 
    FindWindow("****l_traywnd""")
    Call SetWindowPos(Task00000SWP_HIDEWINDOW)
    End Sub

    Private Sub Command2_Click()
    Dim Task As Long
    Task 
    FindWindow("****l_traywnd""")
    Call SetWindowPos(Task00000SWP_SHOWWINDOW)
    End Sub
    [​IMG]

    تشغيل ملف فيديو في Picture

    كود PHP:
    Private Sub Form_Load()
    MMControl1.FileName = ("c:\FileName.dat")
    MMControl1.Command "open"
    MMControl1.hWndDisplay Picture1.hWnd
    End Sub
    [​IMG]

    التقاط صورة للفورم في الحافظ

    كود PHP:
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As ByteByVal bScan As ByteByVal dwFlags As LongByVal dwExtraInfo As Long)

    Private Const 
    VK_SNAPSHOT = &H2C

    Private Sub Command1_Click()
    keybd_event VK_SNAPSHOT111
    End Sub
    [​IMG]

    التقاط صورة للشاشة

    كود PHP:
    Const RC_PALETTE As Long = &H100
    Const SIZEPALETTE As Long 104
    Const RASTERCAPS As Long 38
    Private Type PALETTEENTRY
    peRed 
    As Byte
    peGreen 
    As Byte
    peBlue 
    As Byte
    peFlags 
    As Byte
    End Type
    Private Type LOGPALETTE
    palVersion 
    As Integer
    palNumEntries 
    As Integer
    palPalEntry
    (255) As PALETTEENTRY ' Enough for 256 colors
    End Type
    Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
    End Type
    Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
    End Type
    Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
    Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
    Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
    Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
    Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc 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 Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

    '
    Fill GUID info
    With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
    End With

    'Fill picture info
    With Pic
    .Size = Len(Pic) ' 
    Length of structure
    .Type vbPicTypeBitmap ' Type of Picture (bitmap)
    .hBmp = hBmp ' 
    Handle to bitmap
    .hPal hPal ' Handle to palette (may be null)
    End With

    '
    Create the picture
    OleCreatePictureIndirect(PicIID_IDispatch1IPic)

    'Return the new picture
    Set CreateBitmapPicture = IPic
    End Function
    Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

    '
    Create a compatible device context
    hDCMemory 
    CreateCompatibleDC(hDCSrc)
    'Create a compatible bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    '
    Select the compatible bitmap into our compatible device context
    hBmpPrev 
    SelectObject(hDCMemoryhBmp)

    'Raster capabilities?
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' 
    Raster
    'Does our picture use a palette?
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' 
    Palette
    'What's the size of that palette?
    PaletteSizeScrn GetDeviceCaps(hDCSrcSIZEPALETTE' Size of

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    '
    Set the palette version
    LogPal
    .palVersion = &H300
    'Number of palette entries
    LogPal.palNumEntries = 256
    '
    Retrieve the system palette entries
    GetSystemPaletteEntries(hDCSrc0256LogPal.palPalEntry(0))
    'Create the palette
    hPal = CreatePalette(LogPal)
    '
    Select the palette
    hPalPrev 
    SelectPalette(hDCMemoryhPal0)
    'Realize the palette
    R = RealizePalette(hDCMemory)
    End If

    '
    Copy the source image to our compatible device context
    BitBlt(hDCMemory00WidthSrcHeightSrchDCSrcLeftSrcTopSrcvbSrcCopy)

    'Restore the old bitmap
    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
    '
    Select the palette
    hPal 
    SelectPalette(hDCMemoryhPalPrev0)
    End If

    'Delete our memory DC
    R = DeleteDC(hDCMemory)

    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
    End Function
    Private Sub Form_Load()
    '
    Create a picture object from the screen
    Set Me
    .Picture hDCToPicture(GetDC(0), 00Screen.Width Screen.TwipsPerPixelXScreen.Height Screen.TwipsPerPixelY)
    End Sub
    [​IMG]

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

    كود PHP:
    Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long 

    Private Sub Command1_Click() 
    PaintDesktop Form1.hdc 
    End Sub
    [​IMG]

    ذوبان الشاشة

    كود PHP:
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As LongByVal X As LongByVal Y As LongByVal nWidth As LongByVal nHeight As LongByVal hSrcDC As LongByVal xSrc As LongByVal ySrc As LongByVal dwRop As Long) As Long

    Private Sub Form_KeyDown(KeyCode As IntegerShift As Integer)
    If 
    KeyCode vbKeyEscape Then Unload Me
    End Sub

    Private Sub Form_Load()
    Dim lngDC As Long
    Dim intWidth 
    As IntegerintHeight As Integer
    Dim intX 
    As IntegerintY 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
    (hDC00intWidthintHeightlngDC00vbSrcCopy)
    form1.Visible vbTrue

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

    Call BitBlt
    (lngDCintXintY 1128128lngDCintXintYvbSrcCopy)

    DoEvents
    Loop
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    Set form1 Nothing
    End
    End Sub
    [​IMG]

    نموذج شفاف

    كود PHP:
    Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As LongByValcrKey As LongByVal bAlpha As ByteByVal dwFlags As Long) As Boolean
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongByVal nIndex As LongByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongByVal nIndex As Long) As Long
    Const LWA_ALPHA 2
    Const GWL_EXSTYLE = (-20)
    Const 
    WS_EX_LAYERED = &H80000

    Private Sub Form_Load()
    SetWindowLong hwndGWL_EXSTYLEGetWindowLong(hwndGWL_EXSTYLE) Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd
    0128LWA_ALPHA
    End Sub
    [​IMG]

    شاشة افتتاحية

    كود PHP:
    Private Sub Form_Load()
    Dim StartFinsh
    Form2
    .Show
    Start 
    Timer
    Finsh 
    Start 3
    Do Until Finsh <= Timer
    DoEvents
    Loop
    Unload Form2
    Form1
    .Show
    End Sub
    [​IMG]

    تحريك نص بطريقة مسلية

    كود PHP:
    Private Sub Form_Load()
    Me.Label1.Top 0
    End Sub

    Private Sub Timer1_Timer()
    Me.Height
    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
    [​IMG]

    نص متحرك

    كود PHP:
    Dim Llabel As Integer

    Private Sub Form_Load()
    Form1.ScaleMode 3
    Timer1
    .Interval 100
    End Sub

    Private Sub Timer1_Timer()
    Llabel Llabel 10
    Label1
    .Left Llabel
    If Llabel 300 Then
    Timer1
    .Interval 0
    Timer2
    .Interval 100
    End 
    If
    End Sub

    Private Sub Timer2_Timer()
    Llabel Llabel 10
    Label1
    .Left Llabel
    If Llabel 0 Then
    Timer1
    .Interval 100
    Timer2
    .Interval 0
    End 
    If
    End Sub
    [​IMG]

    رش الألوان على الفورم

    كود PHP:
    Private Sub Form_Load()
    Me.AutoRedraw True
    End Sub

    Private Sub Form_MouseDown(Button As IntegerShift As IntegerAs SingleAs Single)
    Me.CurrentX
    Me.CurrentY
    End Sub
    Private Sub Form_MouseMove(Button As IntegerShift As IntegerAs SingleAs Single)
    Me.PSet (Rnd 255Rnd 255), RGB(Rnd 255Rnd 255Rnd 255)
    Me.PSet (Rnd 255Rnd 255), RGB(Rnd 255Rnd 255Rnd 255)
    Me.PSet (Rnd 255Rnd 255), RGB(Rnd 255Rnd 255Rnd 255)
    Me.PSet (Rnd 255Rnd 255), RGB(Rnd 255Rnd 255Rnd 255)
    End Sub
    [​IMG]

    طريقة جميلة لإغلاق الفورم

    كود PHP:
    Sub SlideWindow(frmSlide As FormiSpeed 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(Form1100)
    End Sub
    [​IMG]

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

    كود PHP:
    Sub Explode(form1 As Form)
    form1.Width 0
    form1
    .Height 0
    form1
    .Show
    For 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
    [​IMG]


     
  5. VeRoS_Dz

    VeRoS_Dz Developer

    الأنتساب:
    ‏10 أغسطس 2012
    المشاركات:
    37
    الإعجابات المتلقاة:
    1
    نقاط الجائزة:
    8
    الوظيفة:
    VeRoS_Dz
    الإقامة:
    VeRoS_Dz
    رد: مكتبة اكواد فيجول بيسك Visual Basic Codes

    بااااااااااك :{11}:

    خلفية جميلة للفورم

    كود PHP:
    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 IntegerRed As IntegerGreen As _
    Integer
    Blue As Integer
    Dim ScaleFactor 
    As DoubleLength As Integer
    ScaleFactor 
    Me.ScaleWidth / (255 6)
    Length Int(ScaleFactor 255)
    Position 0
    Red 
    255
    Blue 
    1
    For Green 1 To Length
    Me
    .Line (Position0)-(PositionMe.ScaleHeight), _
    RGB
    (RedGreen ScaleFactorBlue)
    Position Position 1
    Next Green
    For Red Length To 1 Step -1
    Me
    .Line (Position0)-(PositionMe.ScaleHeight), _
    RGB
    (Red ScaleFactorGreenBlue)
    Position Position 1
    Next Red
    For Blue 0 To Length
    Me
    .Line (Position0)-(PositionMe.ScaleHeight), _
    RGB
    (RedGreenBlue ScaleFactor)
    Position Position 1
    Next Blue
    For Green Length To 1 Step -1
    Me
    .Line (Position0)-(PositionMe.ScaleHeight), _
    RGB
    (RedGreen ScaleFactorBlue)
    Position Position 1
    Next Green
    For Red 1 To Length
    Me
    .Line (Position0)-(PositionMe.ScaleHeight), _
    RGB
    (Red ScaleFactorGreenBlue)
    Position Position 1
    Next Red
    For Blue Length To 1 Step -1
    Me
    .Line (Position0)-(PositionMe.ScaleHeight), _
    RGB
    (RedGreenBlue ScaleFactor)
    Position Position 1
    Next Blue
    End Sub
    [​IMG]

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

    كود PHP:
    Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As LongByVal Y1 As LongByVal X2 As LongByVal Y2 As LongByVal X3 As LongByVal Y3 As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As LongByVal Y1 As LongByVal X2 As LongByVal Y2 As Long) As Long
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As LongByVal Y1 As LongByVal X2 As LongByVal Y2 As Long) As Long
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongByVal hSrcRgn1 As LongByVal hSrcRgn2 As LongByVal nCombineMode As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As LongByVal hRgn As LongByVal bRedraw As Long) As Long

    Private Function fMakeATranspArea(AreaType As StringpCordinate() 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(WidthvbTwipsvbPixels)
    lFHeight ScaleY(HeightvbTwipsvbPixels)
    lOriginalForm CreateRectRgn(00lFwidthlFHeight)
    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(0000)
    CombineRgn lNewFormlOriginalFormltheHoleRGN_DIFF
    SetWindowRgn hWnd
    lNewFormTrue
    Me
    .*******
    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
    [​IMG]

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

    كود PHP:
    Private Sub Form_Load()
    Timer1.Interval 100
    End Sub
    Private Sub Timer1_Timer()
    Label1.Move 2000Label1.Top 100
    If Label1.Top 0 Then
    Label1
    .Top Form1.Height
    End 
    If
    End Sub
    [​IMG]

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

    كود PHP:
    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
    [​IMG]

    نموذج ثلاثي أبعاد

    كود PHP:
    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 (0intScaleHeight)-(intLineWidth0), &HFFFFFFBF
    frmForm
    .Line (0intLineWidth)-(intScaleWidth0), &HFFFFFFBF
    frmForm
    .Line (intScaleWidth0)-(intScaleWidth intLineWidth_
    intScaleHeight
    ), &H808080BF
    frmForm
    .Line (intScaleWidthintScaleHeight intLineWidth)-(0_
    intScaleHeight
    ), &H808080BF
    Dim intCircleWidth 
    As Integer
    intCircleWidth 
    Sqr(intLineWidth intLineWidth intLineWidth _
    intLineWidth)
    frmForm.FillStyle 0
    frmForm
    .FillColor QBColor(15)
    frmForm.Circle (intLineWidthintScaleHeight intLineWidth), _
    intCircleWidth
    _
    QBColor
    (15), -3.1415926, -3.90953745777778
    frmForm
    .Circle (intScaleWidth intLineWidthintLineWidth), _
    intCircleWidth
    _
    QBColor
    (15), -0.78539815, -1.5707963
    frmForm
    .Line (0intScaleHeight)-(00), 0
    frmForm
    .Line (00)-(intScaleWidth 10), 0
    frmForm
    .Line (intScaleWidth 10)-(intScaleWidth 1_
    intScaleHeight 
    1), 0
    frmForm
    .Line (0intScaleHeight 1)-(intScaleWidth 1_
    intScaleHeight 
    1), 0
    frmForm
    .ScaleMode intSaveScaleMode
    End Sub

    Private Sub Form_Resize()
    ThreeDForm Me
    End Sub
    [​IMG]

    معرفة اليوم الحالي

    كود PHP:
    Private Sub Command1_Click()
    Dim Dday As Integer
    Dday 
    Weekday(Date)
    If 
    Dday 1 Then Print "الأحد"
    If Dday 2 Then Print "الاثنين"
    If Dday 3 Then Print "الثلاثاء"
    If Dday 4 Then Print "الأربعاء"
    If Dday 5 Then Print "الخميس"
    If Dday 6 Then Print "الجمعة"
    If Dday 7 Then Print "السبت"
    End Sub
    [​IMG]

    معرفة الشهر الحالي

    كود PHP:
    Private Sub Command1_Click()
    Mmonth Mid(Date42)
    Print 
    MonthName(Mmonth)
    End Sub
    [​IMG]

    الفرق بين تاريخين باليوم

    كود PHP:
    Private Sub Command1_Click()
    On Error GoTo 1
    Dim Form1Date 
    As Date
    Dim Form2Date 
    As Date
    Form1Date 
    Text1.Text
    Form2Date 
    Text2.Text
    Text3
    .Text DateDiff("d"Text1.TextText2.Text) & " يوم"
    Exit Sub
    1 MsgBox 
    ("من فضلك أدخل التاريخ بشكل صحيح")
    End Sub
    [​IMG]

    ترجمة النجوم *** في كلمات السر إلى حروف عادية

    كود PHP:
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As LongByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Type POINTAPI
    As Long
    As Long
    End Type
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongByVal wMsg As LongByVal wParam As LonglParam 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

    GetCursorPos(coord)
    coord.x
    coord.y

    WindowFromPoint(xy)

    Dim NewChar As Integer
    NewChar 
    CLng(0)
    retval SendMessage(hEM_SETPASSWORDCHARByVal NewChar0)
    End Sub
    [​IMG]

    تحويل من HTM إلى Word

    كود PHP:
    Private ASP As ASPTypeLibrary.ScriptingContext
    Private Response As ASPTypeLibrary.Response
    Private Session As ASPTypeLibrary.Session
    Private Server As ASPTypeLibrary.Server
    Private WithEvents IE As SHDocVw.InternetExplorer
    Private Word As Word.Document
    Private Stream As ADODB.Stream
    Private mblnDone

    Public Sub OnStartPage(ByRef ASPLink As ASPTypeLibrary.ScriptingContext)
    Set ASP ASPLink
    Set Response 
    ASPLink.Response
    Set Session 
    ASPLink.Session
    Set Server 
    ASPLink.Server
    Set IE 
    = New SHDocVw.InternetExplorer
    Set Word 
    = New Word.Document
    Set Stream 
    = New ADODB.Stream
    Response
    .Clear
    End Sub

    Private Sub Cleanup()
    Set IE Nothing
    Set Word 
    Nothing
    Set Response 
    Nothing
    Set Session 
    Nothing
    Set Server 
    Nothing
    Set ASP 
    Nothing
    Set Stream 
    Nothing
    End Sub

    Public Sub Download(ByRef pstrURL As Variant)
    Dim lstrPath As String
    Dim lstrFileName 
    As String
    Dim ldblStart 
    As Double
    mblnDone 
    False
    ldblStart 
    Timer
    Call IE
    .Navigate2(pstrURL)

    While 
    IE.Busy And Not mblnDone

    DoEvents

    If (Timer ldblStart) > Server.ScriptTimeout Then
    Call Cleanup
    Err
    .Raise vbObjectError 1"HTML2Word.dll""Connect Timeout - Busy"
    End If
    Wend

    While Not (IE.Document.ReadyState "complete" Or mblnDone)

    DoEvents

    If (Timer ldblStart) > Server.ScriptTimeout Then
    Call Cleanup
    Err
    .Raise vbObjectError 2"HTML2Word.dll""Connect Timeout - Not Complete"
    End If
    Wend
    Call IE
    .Document.Body.createTextRange.execCommand("Copy")

    DoEvents
    lstrFileName 
    Session.SessionID ".doc"
    lstrPath App.Path "\~" Hex(Timer) & "_" lstrFileName

    DoEvents
    On Error Resume Next
    Word
    .Content.Paste

    If Err Then
    Call Cleanup
    Dim lstrMsg
    lstrMsg 
    Err.Description
    On Error 
    Goto 0
    Err
    .Raise vbObjectError 3"HTML2Word.dll""Can Not paste - " lstrMsg
    End 
    If
    On Error Goto 0
    Word
    .SaveAs lstrPath
    Word
    .Close
    Response
    .ContentType "application/octet-stream"
    Response.AddHeader "content-disposition""attatchment; filename=" lstrFileName
    Stream
    .Open
    Stream
    .LoadFromFile lstrPath
    Response
    .BinaryWrite Stream.ReadText
    Stream
    .Close
    Response
    .Flush
    Response
    .End
    FileSystem
    .Kill lstrPath
    End Sub

    Public Sub OnEndPage()
    Call Cleanup
    End Sub

    Private Sub IE_StatusTextChange(ByVal Text As String)
    If 
    Text "Done" Then mblnDone True

    DoEvents
    End Sub

    Private ASP As ASPTypeLibrary.ScriptingContext
    Private Response As ASPTypeLibrary.Response
    Private Session As ASPTypeLibrary.Session
    Private Server As ASPTypeLibrary.Server
    Private WithEvents IE As SHDocVw.InternetExplorer
    Private Word As Word.Document
    Private Stream As ADODB.Stream
    Private mblnDone

    Public Sub OnStartPage(ByRef ASPLink As ASPTypeLibrary.ScriptingContext)
    Set ASP ASPLink
    Set Response 
    ASPLink.Response
    Set Session 
    ASPLink.Session
    Set Server 
    ASPLink.Server
    Set IE 
    = New SHDocVw.InternetExplorer
    Set Word 
    = New Word.Document
    Set Stream 
    = New ADODB.Stream
    Response
    .Clear
    End Sub

    Private Sub Cleanup()
    Set IE Nothing
    Set Word 
    Nothing
    Set Response 
    Nothing
    Set Session 
    Nothing
    Set Server 
    Nothing
    Set ASP 
    Nothing
    Set Stream 
    Nothing
    End Sub

    Public Sub Download(ByRef pstrURL As Variant)
    Dim lstrPath As String
    Dim lstrFileName 
    As String
    Dim ldblStart 
    As Double
    mblnDone 
    False
    ldblStart 
    Timer
    Call IE
    .Navigate2(pstrURL)

    While 
    IE.Busy And Not mblnDone

    DoEvents

    If (Timer ldblStart) > Server.ScriptTimeout Then
    Call Cleanup
    Err
    .Raise vbObjectError 1"HTML2Word.dll""Connect Timeout - Busy"
    End If
    Wend

    While Not (IE.Document.ReadyState "complete" Or mblnDone)

    DoEvents

    If (Timer ldblStart) > Server.ScriptTimeout Then
    Call Cleanup
    Err
    .Raise vbObjectError 2"HTML2Word.dll""Connect Timeout - Not Complete"
    End If
    Wend
    Call IE
    .Document.Body.createTextRange.execCommand("Copy")

    DoEvents
    lstrFileName 
    Session.SessionID ".doc"
    lstrPath App.Path "\~" Hex(Timer) & "_" lstrFileName

    DoEvents
    On Error Resume Next
    Word
    .Content.Paste

    If Err Then
    Call Cleanup
    Dim lstrMsg
    lstrMsg 
    Err.Description
    On Error 
    Goto 0
    Err
    .Raise vbObjectError 3"HTML2Word.dll""Can Not paste - " lstrMsg
    End 
    If
    On Error Goto 0
    Word
    .SaveAs lstrPath
    Word
    .Close
    Response
    .ContentType "application/octet-stream"
    Response.AddHeader "content-disposition""attatchment; filename=" lstrFileName
    Stream
    .Open
    Stream
    .LoadFromFile lstrPath
    Response
    .BinaryWrite Stream.ReadText
    Stream
    .Close
    Response
    .Flush
    Response
    .End
    FileSystem
    .Kill lstrPath
    End Sub

    Public Sub OnEndPage()
    Call Cleanup
    End Sub

    Private Sub IE_StatusTextChange(ByVal Text As String)
    If 
    Text "Done" Then mblnDone True

    DoEvents
    End Sub
    [​IMG]

    السحب والإفلات في TreeView

    كود PHP:
    Option Explicit
    Public dragNode As NodehilitNode As Node

    Private Sub Form_Load()
    'the following code lines will populate the TreeView control
    TreeView1.Nodes.Add , , "First", "First"
    TreeView1.Nodes.Add , , "Second", "Second"
    TreeView1.Nodes.Add "First", tvwChild, "Child", "Child"
    TreeView1.Nodes.Add "Child", tvwChild, "Child2", "Child2"
    End Sub
    Private Sub TreeView1_MouseDown(Button As Integer, Shift As Integer, _
    x As Single, y As Single)
    Set dragNode = TreeView1.HitTest(x, y)
    End Sub

    Private Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not dragNode Is Nothing Then MsgBox (dragNode.Text)
    End Sub

    Private Sub TreeView1_OLEStartDrag(Data As MSComctlLib.DataObject, _
    AllowedEffects As Long)
    '
    If you want to allow parent node draggingdelete the line below
    If dragNode.Parent Is Nothing Then Set dragNode Nothing
    End Sub

    Private Sub TreeView1_OLEDragOver(Data As MSComctlLib.DataObject_
    Effect 
    As LongButton As IntegerShift As Integer_
    As SingleAs SingleState As Integer)
    If 
    Not dragNode Is Nothing Then
    TreeView1
    .DropHighlight TreeView1.HitTest(xy)
    End If

    End Sub
    [​IMG]

    أداة صندوق نص بتأثيرات الXP

    كود PHP:
    Option Explicit
    Public Enum states
    Normal 
    0
    Disable 
    1
    ReadOnly 
    2
    End Enum
    Const m_def_BorderColor = &HB99D7F
    Const m_def_BorderColorOver = &HF0D0B0
    Const m_def_DataFields ""
    Dim m_BorderColor As OLE_COLOR
    Dim m_BorderColorOver 
    As OLE_COLOR
    Dim m_DataFields 
    As String
    Event Change
    ()
    Event Click()
    Event DblClick()
    Event KeyPress(KeyAscii As Integer)
    Event MouseMove(Button As IntegerShift As IntegerAs SingleAs Single'MappingInfo=MyTxt,MyTxt,-1,MouseMove
    Sub RePos()
    On Error Resume Next
    With UserControl
    MyTxt.Width = .Width - 120
    MyTxt.Height = .Height - 120
    MyTxt.Left = 60
    MyTxt.Top = 60
    End With
    End Sub
    Private Sub MyTxt_GotFocus()
    SetMyFocus m_BorderColorOver
    End Sub
    Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
    MyTxt.SetFocus
    End Sub

    Private Sub UserControl_ExitFocus()
    SetMyFocus m_BorderColor
    End Sub
    Private Sub UserControl_Resize()
    RePos
    MyXPtxt MyTxt, vbWhite, Normal
    End Sub

    Private Function MyXPtxt(Txt As TextBox, BackColor As ColorConstants, State As states)
    UserControl.Cls
    UserControl.BackColor = BackColor
    UserControl.ScaleMode = 1
    Txt.Appearance = 0
    Txt.BorderStyle = 0
    UserControl.AutoRedraw = True
    UserControl.DrawWidth = 1
    UserControl.Line (0, 0)-(UserControl.Width, 0), m_BorderColor
    UserControl.Line (0, 0)-(0, UserControl.Height), m_BorderColor
    UserControl.Line (UserControl.Width - 15, 0)-(UserControl.Width - 15, UserControl.Height), m_BorderColor
    UserControl.Line (0, UserControl.Height - 15)-(UserControl.Width, UserControl.Height - 15), m_BorderColor

    If State = Normal Then
    Txt.BackColor = vbWhite
    Txt.Enabled = True
    Txt.Locked = False
    ElseIf State = Disable Then
    Txt.Enabled = False
    Txt.BackColor = RGB(235, 235, 228)
    Txt.ForeColor = RGB(161, 161, 146)
    ElseIf State = ReadOnly Then
    Txt.Enabled = True
    Txt.Locked = True
    End If

    End Function
    Public Property Get Alignment() As Integer
    Alignment = MyTxt.Alignment
    End Property
    Public Property Let Alignment(ByVal New_Alignment As Integer)
    If New_Alignment > 2 Then New_Alignment = 0
    MyTxt.Alignment() = New_Alignment
    PropertyChanged "Alignment"
    End Property
    Private Sub MyTxt_Change()
    RaiseEvent Change
    End Sub
    Private Sub MyTxt_Click()
    RaiseEvent Click
    End Sub
    Private Sub MyTxt_DblClick()
    RaiseEvent DblClick
    End Sub
    Public Property Get Enabled() As Boolean
    Enabled = MyTxt.Enabled
    End Property

    Public Property Let Enabled(ByVal New_Enabled As Boolean)
    MyTxt.Enabled() = New_Enabled
    PropertyChanged "Enabled"
    If New_Enabled Then
    SetMyFocus RGB(127, 157, 185)
    Else
    SetMyFocus RGB(191, 167, 128)
    End If
    End Property
    Public Property Get Font() As Font
    Set Font = MyTxt.Font
    End Property

    Public Property Set Font(ByVal New_Font As Font)
    Set MyTxt.Font = New_Font
    PropertyChanged "Font"
    End Property
    Public Property Get ForeColor() As OLE_COLOR
    ForeColor = MyTxt.ForeColor
    End Property
    Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    MyTxt.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
    End Property
    Private Sub MyTxt_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
    End Sub
    Public Property Get Locked() As Boolean
    Locked = MyTxt.Locked
    End Property
    Public Property Let Locked(ByVal New_Locked As Boolean)
    MyTxt.Locked() = New_Locked
    PropertyChanged "Locked"
    End Property
    Public Property Get MaxLength() As Long
    MaxLength = MyTxt.MaxLength
    End Property
    Public Property Let MaxLength(ByVal New_MaxLength As Long)
    MyTxt.MaxLength() = New_MaxLength
    PropertyChanged "MaxLength"
    End Property
    Private Sub MyTxt_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
    End Sub
    Public Property Get PasswordChar() As String
    PasswordChar = MyTxt.PasswordChar
    End Property
    Public Property Let PasswordChar(ByVal New_PasswordChar As String)
    MyTxt.PasswordChar() = New_PasswordChar
    PropertyChanged "PasswordChar"
    End Property
    Public Property Get SelStart() As Long
    SelStart = MyTxt.SelStart
    End Property
    Public Property Let SelStart(ByVal New_SelStart As Long)
    MyTxt.SelStart() = New_SelStart
    PropertyChanged "SelStart"
    End Property
    Public Property Get SelText() As String
    SelText = MyTxt.SelText
    End Property
    Public Property Let SelText(ByVal New_SelText As String)
    MyTxt.SelText() = New_SelText
    PropertyChanged "SelText"
    End Property
    Public Property Get SelLength() As Long
    SelLength = MyTxt.SelLength
    End Property
    Public Property Let SelLength(ByVal New_SelLength As Long)
    MyTxt.SelLength() = New_SelLength
    PropertyChanged "SelLength"
    End Property
    Public Property Get Text() As String
    Text = MyTxt.Text
    End Property

    Public Property Let Text(ByVal New_Text As String)
    MyTxt.Text() = New_Text
    PropertyChanged "Text"
    End Property
    Public Property Get ToolTipText() As String
    ToolTipText = MyTxt.ToolTipText
    End Property

    Public Property Let ToolTipText(ByVal New_ToolTipText As String)
    MyTxt.ToolTipText() = New_ToolTipText
    PropertyChanged "ToolTipText"
    End Property
    Private Sub UserControl_InitProperties()
    m_DataFields = m_def_DataFields
    MyTxt.Text = "Text" & Mid(Ambient.DisplayName, 11)
    UserControl.Height = 330
    MyTxt.FontName = "Verdana"
    UserControl_Resize
    m_BorderColor = m_def_BorderColor
    m_BorderColorOver = m_def_BorderColorOver
    End Sub

    '
    Load property values from storage
    Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    MyTxt.Alignment PropBag.ReadProperty("Alignment"0)
    MyTxt.BackColor PropBag.ReadProperty("BackColor", &H80000005)
    MyTxt.Enabled PropBag.ReadProperty("Enabled"True)
    Set MyTxt.Font PropBag.ReadProperty("Font"Ambient.Font)
    MyTxt.ForeColor PropBag.ReadProperty("ForeColor", &H80000008)
    MyTxt.Locked PropBag.ReadProperty("Locked"False)
    MyTxt.MaxLength PropBag.ReadProperty("MaxLength"0)
    MyTxt.PasswordChar PropBag.ReadProperty("PasswordChar""")
    MyTxt.SelStart PropBag.ReadProperty("SelStart"0)
    MyTxt.SelText PropBag.ReadProperty("SelText""")
    MyTxt.SelLength PropBag.ReadProperty("SelLength"0)
    MyTxt.Text PropBag.ReadProperty("Text""Text1")
    MyTxt.ToolTipText PropBag.ReadProperty("ToolTipText""")
    m_BorderColor PropBag.ReadProperty("BorderColor"m_def_BorderColor)
    m_BorderColorOver PropBag.ReadProperty("BorderColorOver"m_def_BorderColorOver)
    End Sub
    Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Alignment"MyTxt.Alignment0)
    Call PropBag.WriteProperty("BackColor"MyTxt.BackColor, &H80000005)
    Call PropBag.WriteProperty("Enabled"MyTxt.EnabledTrue)
    Call PropBag.WriteProperty("Font"MyTxt.FontAmbient.Font)
    Call PropBag.WriteProperty("ForeColor"MyTxt.ForeColor, &H80000008)
    Call PropBag.WriteProperty("Locked"MyTxt.LockedFalse)
    Call PropBag.WriteProperty("MaxLength"MyTxt.MaxLength0)
    Call PropBag.WriteProperty("PasswordChar"MyTxt.PasswordChar"")
    Call PropBag.WriteProperty("SelStart"MyTxt.SelStart0)
    Call PropBag.WriteProperty("SelText"MyTxt.SelText"")
    Call PropBag.WriteProperty("SelLength"MyTxt.SelLength0)
    Call PropBag.WriteProperty("Text"MyTxt.Text"Text1")
    Call PropBag.WriteProperty("ToolTipText"MyTxt.ToolTipText"")
    Call PropBag.WriteProperty("Value"Val(MyTxt.Text), 0)
    Call PropBag.WriteProperty("BorderColor"m_BorderColorm_def_BorderColor)
    Call PropBag.WriteProperty("BorderColorOver"m_BorderColorOverm_def_BorderColorOver)
    End Sub
    Private Sub SetMyFocus(LineColor As ColorConstants)
    UserControl.AutoRedraw True
    UserControl
    .DrawWidth 1
    UserControl
    .Line (00)-(UserControl.Width0), LineColor
    UserControl
    .Line (00)-(0UserControl.Height), LineColor
    UserControl
    .Line (UserControl.Width 150)-(UserControl.Width 15UserControl.Height), LineColor
    UserControl
    .Line (0UserControl.Height 15)-(UserControl.WidthUserControl.Height 15), LineColor
    End Sub
    Public Property Get Value() As Double
    Value 
    Val(MyTxt.Text)
    End Property
    Public Property Let Value(ByVal New_Value As Double)
    MyTxt.Text() = New_Value
    PropertyChanged 
    "Value"
    End Property
    Public Property Get BorderColor() As OLE_COLOR
    BorderColor 
    m_BorderColor
    End Property
    Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
    m_BorderColor New_BorderColor
    MyXPtxt MyTxt
    vbWhiteNormal
    PropertyChanged 
    "BorderColor"
    End Property
    Public Property Get BorderColorFocus() As OLE_COLOR
    BorderColorFocus 
    m_BorderColorOver
    End Property
    Public Property Let BorderColorFocus(ByVal New_BorderColorOver As OLE_COLOR)
    m_BorderColorOver New_BorderColorOver
    PropertyChanged 
    "BorderColorOver"
    End Property
    [​IMG]

    أشكال ثلاثية الأبعاد متحركة

    كود PHP:
    Option Explicit

    Const PI 3.141593
    Const PS_SOLID 0
    Dim HALF_SCREEN_WIDTH 
    As Long
    Dim HALF_SCREEN_HEIGHT 
    As Long
    Dim HPC 
    As Long
    Dim VPC 
    As Long
    Dim ASPECT_COMP 
    As Long
    Private obj3dObject As Object3D
    Private Render As PictureBox
    Private Declare Function PolyDraw Lib "gdi32" (ByVal hdc As Longlppt As POINTAPIlpbTypes As ByteByVal cCount As Long) As Long
    Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As LongByVal nWidth As LongByVal crColor As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As LongByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function Polygon Lib "gdi32" (ByVal hdc As LonglpPoint As POINTAPIByVal nCount As Long) As Long
    Private Type Triplet
    First 
    As Long
    Second 
    As Long
    Third 
    As Long
    End Type
    Private Type Point3d
    As Double
    As Double
    As Double
    End Type
    Private Type Point2d
    As Double
    As Double
    End Type
    Private Type Object3D
    Name 
    As String
    Version 
    As String
    NumVertices 
    As Long
    NumTriangles 
    As Long
    Xangle 
    As Long
    Yangle 
    As Long
    Zangle 
    As Long
    ScaleFactor 
    As Double
    CenterofWorld 
    As Point3d
    LocalCoord
    () As Point3d
    RotatedLocalCoord
    () As Point3d
    WorldCoord
    () As Point3d
    CameraCoord
    () As Point3d
    Triangle
    () As Triplet
    ScreenCoord
    () As Point2d
    Isvisible
    () As Boolean
    Color
    () As Long
    End Type
    Private Type Face
    As Double
    As Double
    End Type
    Private Type POINTAPI
    As Long
    As Long
    End Type
    Private Sub CalculateNormals()
    Dim lngIncr As Long
    Dim ObjectFace
    (0 To 2) As Face

    For lngIncr 0 To obj3dObject.NumTriangles 1

    ObjectFace
    (0).obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).First).X
    ObjectFace
    (0).obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).First).Y
    ObjectFace
    (1).obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Second).X
    ObjectFace
    (1).obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Second).Y
    ObjectFace
    (2).obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Third).X
    ObjectFace
    (2).obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Third).Y

    If ((ObjectFace(0).ObjectFace(2).Y) * (ObjectFace(1).ObjectFace(0).X)) - _
    ((ObjectFace(0).ObjectFace(2).X) * (ObjectFace(1).ObjectFace(0).Y)) > 0 Then
    obj3dObject
    .Isvisible(lngIncr) = True
    Else
    obj3dObject.Isvisible(lngIncr) = False
    End 
    If

    Next

    End Sub


    Public Sub SetRotations(Optional X As DoubleOptional Y As DoubleOptional Z As Double)

    If 
    Not (IsMissing(X)) Then
    obj3dObject
    .Xangle X
    End 
    If

    If 
    Not (IsMissing(Y)) Then
    obj3dObject
    .Yangle Y
    End 
    If

    If 
    Not (IsMissing(Z)) Then
    obj3dObject
    .Zangle Z
    End 
    If

    End Sub


    Public Sub SetTranslations(Optional XPos As VariantOptional YPos As VariantOptional ZPos As Variant)

    If 
    Not (IsMissing(XPos)) Then
    obj3dObject
    .CenterofWorld.XPos
    End 
    If

    If 
    Not (IsMissing(YPos)) Then
    obj3dObject
    .CenterofWorld.YPos
    End 
    If

    If 
    Not (IsMissing(ZPos)) Then
    obj3dObject
    .CenterofWorld.ZPos
    End 
    If

    End Sub


    Public Sub LoadObject(strFileName As StringDeviceContext As PictureBoxlngCenterofWorldX As DoublelngCenterofWorldY As DoublelngCenterofWorldZ As DoubledblScaleFactor As DoublelngSetXRotation As LonglngSetYRotation As LonglngSetZRotation As Long)

    Dim strTemp As String
    Dim lngNumTemp 
    As Long
    Dim lngNumVertices 
    As Long
    Dim lngNumTriangles 
    As Long
    Set Render 
    DeviceContext
    HALF_SCREEN_HEIGHT 
    Render.ScaleHeight 2
    HALF_SCREEN_WIDTH 
    Render.ScaleWidth 2
    ASPECT_COMP 
    = (Render.ScaleHeight) / ((Render.ScaleWidth 3) / 4)
    HPC HALF_SCREEN_WIDTH / (Tan((60 2) * (PI 180)))
    VPC HALF_SCREEN_HEIGHT / (Tan((60 2) * (PI 180)))
    obj3dObject.CenterofWorld.lngCenterofWorldX
    obj3dObject
    .CenterofWorld.lngCenterofWorldY
    obj3dObject
    .CenterofWorld.lngCenterofWorldZ
    obj3dObject
    .ScaleFactor dblScaleFactor
    obj3dObject
    .Xangle lngSetXRotation
    obj3dObject
    .Yangle lngSetYRotation
    obj3dObject
    .Zangle lngSetZRotation
    Open strFileName 
    For Input As 1
    Line Input 
    #1, strTemp
    If strTemp <> "3D OBJECT DEFINITION FILE" Then
    MsgBox 
    "Not a valid object file!"vbOKOnly vbCritical"Open"
    Exit Sub
    End 
    If
    Line Input #1, strTemp
    obj3dObject.Version Trim(strTemp)
    Line Input #1, strTemp
    obj3dObject.Name Trim(strTemp)

    Line Input #1, strTemp
    Line Input #1, strTemp
    Do While strTemp <> ""

    lngNumVertices lngNumVertices 1
    ReDim Preserve obj3dObject
    .LocalCoord(0 To lngNumVertices 1)

    obj3dObject.LocalCoord(lngNumVertices 1).CDbl(Left(strTempInStr(1strTemp","vbTextCompare) - 1))
    lngNumTemp InStr(1strTemp","vbTextCompare)
    obj3dObject.LocalCoord(lngNumVertices 1).CDbl(Mid(strTemplngNumTemp 1InStr(lngNumTemp 1strTemp","vbTextCompare) - lngNumTemp 1))
    lngNumTemp InStr(lngNumTemp 1strTemp","vbTextCompare)
    obj3dObject.LocalCoord(lngNumVertices 1).CDbl(Right(strTempLen(strTemp) - lngNumTemp))

    Line Input #1, strTemp
    Loop
    obj3dObject
    .NumVertices lngNumVertices
    Line Input 
    #1, strTemp
    Do While strTemp <> "END"

    lngNumTriangles lngNumTriangles 1
    ReDim Preserve obj3dObject
    .Triangle(0 To lngNumTriangles 1)
    ReDim Preserve obj3dObject.Color(0 To lngNumTriangles 1)

    obj3dObject.Triangle(lngNumTriangles 1).First CDbl(Left(strTempInStr(1strTemp","vbTextCompare) - 1))
    lngNumTemp InStr(1strTemp","vbTextCompare)
    obj3dObject.Triangle(lngNumTriangles 1).Second CDbl(Mid(strTemplngNumTemp 1InStr(lngNumTemp 1strTemp","vbTextCompare) - lngNumTemp 1))
    lngNumTemp InStr(lngNumTemp 1strTemp","vbTextCompare)
    obj3dObject.Triangle(lngNumTriangles 1).Third CDbl(Mid(strTemplngNumTemp 1InStr(lngNumTemp 1strTemp","vbTextCompare) - lngNumTemp 1))
    lngNumTemp InStr(lngNumTemp 1strTemp","vbTextCompare)
    obj3dObject.Color(lngNumTriangles 1) = CLng(Right(strTempLen(strTemp) - lngNumTemp))

    Line Input #1, strTemp
    Loop
    obj3dObject
    .NumTriangles lngNumTriangles

    Close 
    #1
    ReDim Preserve obj3dObject.RotatedLocalCoord(0 To obj3dObject.NumVertices 1)
    ReDim Preserve obj3dObject.WorldCoord(0 To obj3dObject.NumVertices 1)
    ReDim Preserve obj3dObject.CameraCoord(0 To obj3dObject.NumVertices 1)
    ReDim Preserve obj3dObject.ScreenCoord(0 To obj3dObject.NumVertices 1)
    ReDim Preserve obj3dObject.Isvisible(0 To obj3dObject.NumTriangles 1)

    End Sub
    Private Sub LocaltoWorld()

    Dim lngIncr As Long
    For lngIncr 0 To obj3dObject.NumVertices 1
    obj3dObject
    .WorldCoord(lngIncr).obj3dObject.RotatedLocalCoord(lngIncr).obj3dObject.CenterofWorld.X
    obj3dObject
    .WorldCoord(lngIncr).obj3dObject.RotatedLocalCoord(lngIncr).obj3dObject.CenterofWorld.Y
    obj3dObject
    .WorldCoord(lngIncr).obj3dObject.RotatedLocalCoord(lngIncr).obj3dObject.CenterofWorld.Z
    Next

    End Sub
    Private Sub Project3dto2d()

    Dim lngIncr As Long
    For lngIncr 0 To obj3dObject.NumVertices 1
    obj3dObject
    .ScreenCoord(lngIncr).= (obj3dObject.WorldCoord(lngIncr).HPC obj3dObject.WorldCoord(lngIncr).Z) + HALF_SCREEN_WIDTH
    obj3dObject
    .ScreenCoord(lngIncr).= (-obj3dObject.WorldCoord(lngIncr).VPC ASPECT_COMP obj3dObject.WorldCoord(lngIncr).Z) + HALF_SCREEN_HEIGHT
    Next

    End Sub
    Public Sub RenderObject()

    Dim lngIncr As Long
    Dim ScreenBuffer
    (0 To 2) As POINTAPI
    Dim Brush 
    As Long
    Dim Pen 
    As Long
    Dim OldBrush 
    As Long
    Dim OldPen 
    As Lon
    [​IMG]

    إظهار شاشة خصائص الملف

    كود PHP:
    Const SEE_MASK_INVOKEIDLIST = &HC
    Const SEE_MASK_NOCLOSEPROCESS = &H40
    Const SEE_MASK_FLAG_NO_UI = &H400
    Private Type ****LEXECUTEINFO
    cbSize 
    As Long
    fMask 
    As Long
    hwnd 
    As Long
    lpVerb 
    As String
    lpFile 
    As String
    lpParameters 
    As String
    lpDirectory 
    As String
    nShow 
    As Long
    hInstApp 
    As Long
    lpIDList 
    As Long
    lpClass 
    As String
    hkeyClass 
    As Long
    dwHotKey 
    As Long
    hIcon 
    As Long
    hProcess 
    As Long
    End Type
    Private Declare Function ****lExecuteEx Lib "****l32.dll" Alias "****lExecuteEx" (SEI As ****LEXECUTEINFO) As Long
    Sub ShowProps
    (FileName As StringOwnerhWnd As Long)
    Dim SEI As ****LEXECUTEINFO
    Dim r 
    As Long
    With SEI
    'Set the structure's size
    .cbSize Len(SEI)
    'Seet the mask
    .fMask = SEE_MASK_NOCLOSEPROCESS Or _
    SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
    '
    Set the owner window
    .hwnd OwnerhWnd
    'Show the properties
    .lpVerb = "properties"
    '
    Set the filename
    .lpFile FileName
    .lpParameters vbNullChar
    .lpDirectory vbNullChar
    .nShow 0
    .hInstApp 0
    .lpIDList 0
    End With
    = ****lExecuteEX(SEI)
    End Sub
    Private Sub Form_Load()
    ShowProps "c:\config.sys"Me.hwnd
    End Sub
    نجوم تعني S H E L
     
  6. ali Alsalih

    ali Alsalih Developer

    الأنتساب:
    ‏7 يونيو 2012
    المشاركات:
    36
    الإعجابات المتلقاة:
    0
    نقاط الجائزة:
    6
    رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

    خلفيه + جميييييييـله جداجدا للفـورم

    ضع هذا الكود في الفورم فـقط!!

    كود PHP:
    function dist(x1y1x2y2) as single
    dim a 
    as singleas single
    = (x2 y1) * (x2 x1)
    = (y2 y1) * (y2 y1)
    dist sqr(b)
    end function
    sub moveit(abt)
    = (t) * b
    end sub

    private sub form_click()
    cls
    dim t 
    as singlex1 as singley1 as single
    dim x2 
    as singley2 as singlex3 as single
    dim y3 
    as singlex4 as singley4 as single

    scale 
    (-320200)-(320, -200)
    0.05
    x1 
    = -320Y1 200
    x2 
    320Y2 200
    x3 
    320Y3 = -200
    x4 
    = -320Y4 = -200
    do until dist(x1y1x2y2) < 10
    line 
    (x1y1)-(x2y2)
    line -(x3y3)
    line -(x4y4)
    line -(x1y1)
    moveit x1x2t
    moveit y1
    y2t
    moveit x2
    x3t
    moveit y2
    y3t
    moveit x3
    x4t
    moveit y3
    y4t
    moveit x4
    x1t
    moveit y4
    y1t
    loop
    end sub

    private sub form_resize()
    cls
    dim t 
    as singlex1 as singley1 as single
    dim x2 
    as singley2 as singlex3 as single
    dim y3 
    as singlex4 as singley4 as single

    scale 
    (-320200)-(320, -200)
    0.05
    x1 
    = -320Y1 200
    x2 
    320Y2 200
    x3 
    320Y3 = -200
    x4 
    = -320Y4 = -200
    do until dist(x1y1x2y2) < 10
    line 
    (x1y1)-(x2y2)
    line -(x3y3)
    line -(x4y4)
    line -(x1y1)
    moveit x1x2t
    moveit y1
    y2t
    moveit x2
    x3t
    moveit y2
    y3t
    moveit x3
    x4t
    moveit y3
    y4t
    moveit x4
    x1t
    moveit y4
    y1t
    loop
    end sub
     
  7. ali Alsalih

    ali Alsalih Developer

    الأنتساب:
    ‏7 يونيو 2012
    المشاركات:
    36
    الإعجابات المتلقاة:
    0
    نقاط الجائزة:
    6
    رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

    برنآمج ساعة رقمیة مع تاريخ. الأدوات المطلوبة :

    إلى 100 Interval غیر خاصیة Timer ومؤقت زمني 1 Label ضع ٢أداة عنوان

    : Timer1_Timer أكتب الكود الآتي في

    كود PHP:
    Private Sub Timer1_Timer()
    Label1.Caption=Time
    Label2
    .Caption=Date
    End Sub
     
  8. ali Alsalih

    ali Alsalih Developer

    الأنتساب:
    ‏7 يونيو 2012
    المشاركات:
    36
    الإعجابات المتلقاة:
    0
    نقاط الجائزة:
    6
    رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

    البرنامج الأول عبارة عن مستعرض صور بسیط. افتح مشروع جديد ثم ضع مايلي:

    فیظھر مربع حوار نختار Ctrl+T نضغط على ، Image ٢ أزرار ، أداة عرض الصور 1

    ثم نظغط على موافق Microsoft Common Dialog control 6.0(SP منه الأداة ( 6

    ونقوم بإدراجه على الفورم. نكتب الكود الآتي بالحدث

    كود PHP:
    Form_Load 
    Private Sub Form_Load()
    Form_Resize
    End Sub
    Form_Resize والكود الآتي بالحدث
    Private Sub Form_Resize()
    On Error Resume Next
    Image1
    .Width Me.Width 360
    Image1
    .Height Me.Height 1180
    End Sub
    وللزر الأول 
    "تحمیل" :
    Private 
    Sub CmdOpen_Click()
    On Error Resume Next
    CommonDialog1
    .CancelError True
    CommonDialog1
    .Filter="All Picture Files|*.bmp;*.jpg;*.gif;*.wmf|"
    CommonDialog1.ShowOpen
    Image1
    .Picture LoadPicture(CommonDialog1.FileName)
    End Sub
    وللزر الثاني 
    " حفظ" :
    Private 
    Sub CmdSave_Click()
    On Error Resume Next
    CommonDialog1
    .CancelError True
    CommonDialog1
    .Filter"JPG|*.jpg| BMP|*.bmp| Gif|*.gif|"
    CommonDialog1.ShowSave
    SavePicture Image1
    .PictureCommonDialog1.FileName
    End Sub
     
  9. ali Alsalih

    ali Alsalih Developer

    الأنتساب:
    ‏7 يونيو 2012
    المشاركات:
    36
    الإعجابات المتلقاة:
    0
    نقاط الجائزة:
    6
    رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

    كود جعل الفورم شفاف

    في ال ( General )

    كود PHP:
    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
    في مكان تحميل الفورم ( Form Load )

    كود PHP:
    Private Sub Form_Load()
    SetWindowLong hwnd GWL_EXSTYLE GetWindowLong(hwnd GWL_EXSTYLE) Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd 
    128 LWA_ALPHA
    End Sub
     
  10. ali Alsalih

    ali Alsalih Developer

    الأنتساب:
    ‏7 يونيو 2012
    المشاركات:
    36
    الإعجابات المتلقاة:
    0
    نقاط الجائزة:
    6
    رد: مكتبة اكواد فيجول بيسك 6 Visual Basic 6 Codes

    لفتح البرنامج بطريقة جميلة

    كود PHP:
    Sub Explode(form1 As Form)
    form1.Width 0
    form1
    .Height 0
    form1
    .Show
    For 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
     

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