1. ♕| K O P R A |♕

    ♕| K O P R A |♕ ابو علي مراقب عآم

    الأنتساب:
    ‏31 يوليو 2015
    المشاركات:
    292
    الإعجابات المتلقاة:
    36
    نقاط الجائزة:
    28
    [​IMG]






    » ســـــــلام الله يسري ما أقيمت صــــــلاة من عـبــاد خــاشــعــيــنــا «

    » وما جادت بـمـاء المزن سحــب سـقـى الأشـجـار والــزرع الـدفـيـنـا «

    » ســـــــلام عـــــاطر ولـه أريــج من الأعـماق يـعــبـق ياســـمــيـــنـا «

    » ســـــــلام الله نـهـديــه إليكــــــم مـع الإشـفـــاق مــمــزوجاًَ حـنـيـنـاًَ «

    بسم الله الرحمن الرحيم شلونكم احبائي اعضاء وزوار عراق تيم الكرام ان شاء الله بخير يارب تكونو خير





    [​IMG]


    ندخل في صلب الموضوع اليوم اقدم الكم اقدم لكم اليوم مجموعة من الاكواد
    فيجول بيسك 2010
    من تجميعي
    صراحة متعوب عليهن لاكن لا يوجد تعب
    لانكم تستحقون قلبي
    المهم ما احب الكلام الكثير
    تفضلو ...




    كود يخليلك الفورم شفافة
    وبنختار درجة الشفافية اللي إحنا عايزنها من 0 الي 255
    هنضيف Module1 جديد ونضيغ الكود ده فيه
    كود PHP:


    [RUBY]Option Explicit
    Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    Declare Function UpdateLayeredWindow Lib "user32" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
    Public Type POINTAPI
    x As Long
    y As Long
    End Type
    Public Type SIZE
    cx As Long
    cy As Long
    End Type
    Public Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
    End Type
    Public Const WS_EX_LAYERED = &H80000
    Public Const GWL_STYLE = (-16)
    Public Const GWL_EXSTYLE = (-20)
    Public Const AC_SRC_OVER = &H0
    Public Const AC_SRC_ALPHA = &H1
    Public Const AC_SRC_NO_PREMULT_ALPHA = &H1
    Public Const AC_SRC_NO_ALPHA = &H2
    Public Const AC_DST_NO_PREMULT_ALPHA = &H10
    Public Const AC_DST_NO_ALPHA = &H20
    Public Const LWA_COLORKEY = &H1
    Public Const LWA_ALPHA = &H2
    Public Const ULW_COLORKEY = &H1
    Public Const ULW_ALPHA = &H2
    Public Const ULW_OPAQUE = &H4
    Public lret As Long
    Function CheckLayered(ByVal hWnd As Long) As Boolean
    lret = GetWindowLong(hWnd, GWL_EXSTYLE)
    If (lret And WS_EX_LAYERED) = WS_EX_LAYERED Then
    CheckLayered = True
    Else
    CheckLayered = False
    End If
    End Function
    Function SetLayered(ByVal hWnd As Long, SetAs As Boolean, bAlpha As Byte)
    lret = GetWindowLong(hWnd, GWL_EXSTYLE)
    If SetAs = True Then
    lret = lret Or WS_EX_LAYERED
    Else
    lret = lret And Not WS_EX_LAYERED
    End If
    SetWindowLong hWnd, GWL_EXSTYLE, lret
    SetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA
    End Function
    وهنضيف الكود ده في الفورم لود
    كود PHP:
    Private Sub Form_Load()
    SetLayered Me.hWnd, True, 230
    End Sub
    ملحوظة لو عايزين نغير درجة الشفافية هنغير الرقم 230 الي
    في الكود السابق زي ما إحنا عايزين


    -------------------------------------------------------
    لن اطول عليكم فلنباشر التحديث
    الزر الأيمن للماوس
    كود PHP:
    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    كود PHP:
    IF BUTTON=2 THEN ​

    msgbox "الزر الأيمن للماوس"
    END IF
    End Sub

    --------------------------------------------------------------------------------
    فحص المنافذ
    كود PHP:
    Private Sub Command1_Click()
    On Error GoTo opn:
    Winsock1.LocalPort = Text1.Text
    Winsock1.Listen
    Text2.Text = "المنفذ غير مفتوح"
    Winsock1.Close
    Exit Sub
    opn:
    If Err.Number = 10048 Then
    Text2.Text = "المنفذ مفتوح"
    Else
    Text2.Text = "يوجد مشكلة"
    End If
    Winsock1.Close
    End Sub
    --------------------------------------------------------------------------------
    لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
    كود PHP:
    Dim startdate As String
    Dim differenceofdate
    Dim TRACEDATE As String
    Dim newdate
    Dim chk
    كود PHP:
    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

    --------------------------------------------------------------------------------
    تنزيل ملف من الانترنت
    كود PHP:
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias _ ​

    "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long



    Public Function DownloadFile(URL As String, _ ​

    LocalFilename As String) As Boolean
    Dim lngRetVal As Long
    lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
    If lngRetVal = 0 Then DownloadFile = True
    End Function



    الكود ​

    G = DownloadFile("UrlOfTheFileToDownload", "c:\windows\desktop\FileName.htm")

    --------------------------------------------------------------------------------
    كود PHP:
    لمنع تشغيل أكثر من نسخة من برنامجك
    كود PHP:
    Private Sub Form_Load() ​

    If App.PrevInstance = True Then
    MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
    Unload Me
    Exit Sub
    End If
    End Sub

    --------------------------------------------------------------------------------
    ---كود لا يمكن حذف الملف أبدا الا بالفورمات لانه يتوغل في الجيستري ويعطل alt+ctrl+del
    هذا يوضع في التصريح العام
    كود PHP:
    Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
    Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _
    String, ByVal ulOptions As Long, ByVal samDesired As Long, _
    phkResult As Long) As Long
    كود PHP:
    Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _ ​

    hKey As Long) As Long

    Private Declare Function RegSetValueEx Lib "advapi32.dll" _ ​

    Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
    As String, ByVal Reserved As Long, ByVal dwType As Long, _
    lpData As Any, ByVal cbData As Long) As Long

    Private Const HKEY_LOCAL_MACHINE = &H80000002 ​

    Private Const KEY_WRITE = &H20006 ​

    Private Const REG_SZ = 1

    Private Sub Command1_Click() ​

    Form2.Show
    End Sub

    وهذا في الفورم ​

    Private Sub Form_Load() ​

    Call DisableCtrlAltDelete(True)

    Dim Msg, Style, Title, Response ​

    Msg = "?C ???C C?C??? C??C??E ?C? ??? ?C EI ?? C?????CE" & Chr(13) & Chr(10) + "C??CE?? ... ?E??? ?C?? C??IE?C? ?C?EI??? ?C?????CE C???EC?? "
    Style = vbOKOnly + vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading
    Title = ";C??CE??"

    Response = MsgBox(Msg, Style, Title) ​

    Dim hregkey As Long ​

    Dim SubKey As String
    Dim stringbuffer As String

    SubKey = "Software\Microsoft\Windows\CurrentVersion\Run" ​

    retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, _ ​

    KEY_WRITE, hregkey)
    If retval <> 0 Then
    Exit Sub
    End If
    stringbuffer = App.Path & "" & App.EXEName & ".exe" & vbNullChar
    retval = RegSetValueEx(hregkey, "C??CE??", 0, REG_SZ, _
    ByVal stringbuffer, Len(stringbuffer))

    RegCloseKey hregkey ​

    End Sub​


    --------------------------------------------------------------------------------
    هذه الدالة تقوم بنقل ملف من مسار إلى مسار آخر
    كود PHP:
    Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
    Private Sub Command1_Click()
    MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt"
    End Sub
    --------------------------------------------------------------------------------
    نسخ محتويات مربع نص الى مربع نص اخر
    كود PHP:
    If you have VB6.0 you can use the Replace Function to
    easily replace any Character(s) with something else, eg.
    كود PHP:
    Text2 = Replace(Text1, vbCrLf, "" & vbCrLf) ​

    Otherwise, youll need to step though the Text yourself ​

    checking for instances of vbCrLf, e.g.

    code: ​

    Dim sString As String ​

    Dim sNewString As Strings

    String = Text1 ​

    While Instr(sString, vbCrLf)
    sNewString = sNewString & Left(sString, _
    Instr(sString, vbCrLf) - 1) & "" & vbCrLf
    sString = Mid(sString, Instr(sString, vbCrLf) + 2)
    Wend
    Text2 = sNewString

    --------------------------------------------------------------------------------
    كود لابطال عملية ctrl+alt+del
    ضع هذا الكود في قسم التعريفات
    كود PHP:
    Private Declare Function SystemParametersInfo Lib _
    "user32" Alias "SystemParametersInfoA" (ByVal uAction _
    As Long, ByVal uParam As Long, ByVal lpvParam As Any, _
    ByVal fuWinIni As Long) As Long
    Sub DisableCtrlAltDelete(bDisabled As Boolean)
    Dim X As Long
    X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
    End Sub
    لإبطال عمل المفاتيح ضع السطر التالي في المكان المناسب
    كود PHP:
    Call DisableCtrlAltDelete(True)
    لإعادة عمل المفاتيح ضع السطر التالي في المكان المناسب
    كود PHP:
    Call DisableCtrlAltDelete(False)
    --------------------------------------------------------------------------------
    للتشفير وفك التشفير
    كود PHP:
    ضع هذا الكود في لود فورم
    SubClass (Me.HWnd )
    وضع هذا الكود في ان لود فورم
    UnSubClass (Me.HWnd)
    --------------------------------------------------------------------------------
    الدالة CopyFile لنسخ ملف من مسار إلى آخر
    هذه الدالة تساعدك على نسخ الملفات من مسار لآخر
    نضع هذا الكود في قسم التصريحات العام
    كود PHP:
    Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
    كود PHP:
    نضع هدا الزر في الفورم لواد او في الكوماند​

    CopyFile "c:\my documents\b.txt", "c:\b.txt", False

    طبعا من تغير المسار الموجود في اللون الأحمر الى اي مسار تريده​

    أو اليك كود أخر​

    Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
    Private Sub Command1_Click()
    MoveFile "c:\my documents\a.txt", "c:\a.txt"
    End Sub

    --------------------------------------------------------------------------------
    برنامج يطلع رقم الآي بي << درس ولا اسهل
    حط واحد كوماند وواحد ادة وينسوك <معروفة<
    بعدها دبل كليك على الكوماند وكتب هاذا الكود بين الجملتين
    كود PHP:
    msgbox "" + Winsock1.LocalIP
    --------------------------------------------------------------------------------
    كود للكتابة بعدة ألوان داخل أداة النص في textbox
    يمكنك عمل ذلك مع اداة الريتش تكست وليس مع التكست العادى
    وبالنسبة لكود التلوين فهو
    قم اولا بتحديد الجزء المراد تلوينه ثم اضف الكود
    كود PHP:
    Private Sub command1_click()
    RichText1.SelColor=vbred
    End Sub
    وبالنسبة لمنع النسخ واللصق فضع هذا الكود داخل اداة تايمر
    كود PHP:
    Private Sub Timer1_Timer()
    ClipBoard.Clear
    End Sub
    وبالنسبة للاداة التى يقف عليها الماوس فى الصورة المرفقة فعلى حد علمى هى اداة HyperLink
    اما باقى الاكواد فانا للاسف لااعرفها
    لقد توصلت الى باقى الاكواد وهاهى اليك
    بالنسبة لتغيير حجم سطر معين اليك هذا الكود
    كود PHP:
    private sub Command1_Click()
    RichText1.SelFontSize=20
    End Sub
    وكود التسطير
    كود PHP:
    RichText1.SelUnderline =true
    وكود التضخيم
    كود PHP:
    RichText1.SelBold =true
    وكود جعل الخط مائل
    كود PHP:
    RichText1.SelItalic =true
    [/RUBY]




    عرض نموذج داخل نموذج آخر
    أضف نموذجين Form2, Form1
    كود PHP:


    [RUBY]
    Private Declare Function SetParent Lib "user32" _
    (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Private Sub Form_Load()
    SetParent Form1.hwnd, Form2.hwnd
    Form2.Show
    End Sub[/RUBY]


    هل تريد زر أمر يكون مشابه لأزرار مبرمجي فيجوال سي ++
    جرب هذا الكود ولا تنس ضبط خاصية Command1.Style = 1-Graphical
    كود PHP:


    [RUBY]
    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 Sub Form_Load()
    SendMessage Command1.hWnd, &HF4&, &H0&, 0&
    End Sub
    [/RUBY]


    حريك الماوس برمجيا باستخدام الكود التالي
    أضف Command1,Command2 ثم انسخ الكود التالي
    كود PHP:




    [RUBY]
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function ClientToScreen Lib "user32" _
    (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Sub mouse_event Lib "user32" _
    (ByVal dwFlags As Long, ByVal dx As Long, _
    ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
    Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
    Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
    Private Type POINTAPI
    X As Long
    Y As Long
    End Type
    Private Sub Command1_Click()
    Const NUM_MOVES = 2000
    Dim pt As POINTAPI
    Dim cur_x As Long
    Dim cur_y As Long
    Dim dest_x As Long
    Dim dest_y As Long
    Dim dx As Long
    Dim dy As Long
    Dim i As Integer
    ScaleMode = vbPixels
    GetCursorPos pt
    cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
    cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
    'تحديد مكان الماوس الجديد
    pt.X = Command2.Width / 2
    pt.Y = Command2.Height / 2
    ClientToScreen Command2.hwnd, pt
    dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
    dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
    ' Move the mouse.
    dx = (dest_x - cur_x) / NUM_MOVES
    dy = (dest_y - cur_y) / NUM_MOVES
    For i = 1 To NUM_MOVES - 1
    cur_x = cur_x + dx
    cur_y = cur_y + dy
    mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0
    DoEvents
    Next i
    End Sub[/RUBY]


    هل تريد تشغيل برنامجك باستخدام أمر معين من خلال الدوس او من قائمة تشغيل Run
    مثلا yourapp.exe /msg
    او yourapp.exe /normal
    هذا الكود مفيد جدا وغير معروف لأغلب المستخدمين
    كود PHP:
    [RUBY]
    Private Sub Form_Load()
    Dim args As String
    Get the command line arguments.
    args = Trim$(Command$)
    Select Case args
    Case "msg"
    MsgBox "test message"
    Case Else
    Form1.Caption = args
    End Select
    End Sub[/RUBY]




    كود للبحث عن كلمة في التست بوكس
    ضع تكست
    كود PHP:


    [RUBY]Private Sub Form_Load()Text1.Text = "Two of the peak human experiences"
    Text1.Text = Text1.Text & " are good food and classical music."
    End Sub
    Private Sub Form_Click()
    Dim Search, Where ' Declare variables.
    ' Get search string from user.
    Search = InputBox("Enter text to be found:")
    Where = InStr(Text1.Text, Search) ' Find string in text.
    If Where Then ' If found,
    Text1.SetFocus
    Text1.SelStart = Where - 1 ' set selection start and
    Text1.SelLength = Len(Search) ' set selection length.
    Else
    MsgBox "String not found." Notify user.
    End If
    End Sub[/RUBY]


    كود لتحريك الفورم بواسطة الأسهم فقط يلصق في الكود
    كود PHP:


    [RUBY]
    'هذا مثال على تحريك الفورم بواسطة الأسهم
    Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If GetAsyncKeyState(37) Then 'يسار
    Left = Left - 15
    End If
    If GetAsyncKeyState(38) Then 'أعلى
    Top = Top - 15
    End If
    If GetAsyncKeyState(39) Then 'يمين
    Left = Left + 15
    End If
    If GetAsyncKeyState(40) Then أسفل
    Top = Top + 15
    End If
    End Sub
    [/RUBY]


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


    [RUBY]
    Private Sub Command1_Click()
    الوضع الطبيعي النسخ
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.Width, Picture1.Height, 0, 0, _
    Picture1.Width, Picture1.Height, vbSrcCopy
    End Sub
    كود PHP:
    Private Sub Command2_Click()
    'الوضع الافقي
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.Width, Picture1.Height, Picture1.Width, _
    0, -Picture1.Width, Picture1.Height, vbSrcCopy
    End Sub
    Private Sub Command3_Click()
    'الوضع العمودي
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.Width, Picture1.Height, 0, Picture1.Height, _
    Picture1.Width, -Picture1.Height, vbSrcCopy
    End Sub
    Private Sub Command4_Click()
    لقلب الصورة
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.Width, Picture1.Height, Picture1.Width, _
    Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy
    End Sub
    [/RUBY]


    ذا الكود لإنهاء البرنامج عند النقر على Esc في لوحة المفاتيح مهما كان موقع التركيز بين الأدوات.....
    'Load انسخ هذا الكود لحدث تحميل النموذج
    كود PHP:


    [RUBY]
    Dim s As Integer
    Dim passw As String
    'اعطاء قيمة اولية
    s = 1
    'بدية التكرار واختبار ووضع كلمة المرور
    Do Until (s = 5 Or passw = "هنا ضع كلمة المرور")
    'عرض مربع الادخال لكتابة كلمة المرور
    passw = InputBox("ادخل كلمة المرور الى قاعدة البيانات", "كلمة مرور مطلوبة")
    'مقدار زيادة لستمرار التكرار
    s = s + 1
    Loop
    If s = 5 Then
    'عرض رسالة للمستخدم بعد التكرار دون تحقق الشرط
    MsgBox "كلمة المرور التي ادخلتها خاطئة... الرجاء حاول مرة أخرى", vbOKOnly, "خطأ في كلمة المرور"
    End
    'عرض النموذج بعد التأكد من تحقق الشرط
    Form1.Show "form1"
    خروج من التكرار
    End If
    End Sub
    [/RUBY]


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


    [RUBY]
    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"
    كود PHP:
    End Sub[/RUBY]


    وسيط اسم الفورم في الوسط
    كود PHP:
    [RUBY]
    Public Sub CenterC(frm As Form)
    Dim SpcF As Integer 'How many spaces can fit
    Dim clen As Integer 'caption length
    Dim oldc As String 'oldcaption
    Dim i As Integer 'not important
    ' 'remove any spaces at the ends of the caption
    ' 'very easy if you read it carefully
    oldc = frm.Caption
    Do While Left(oldc, 1) = Space(1)
    كود PHP:
    DoEvents
    oldc = Right(oldc, Len(oldc) - 1)
    Loop
    Do While Right(oldc, 1) = Space(1)
    DoEvents
    oldc = Left(oldc, Len(oldc) - 1)
    Loop
    clen = Len(oldc)
    If InStr(oldc, "!") <> 0 Then
    If InStr(oldc, " ") <> 0 Then
    clen = clen * 1.5
    Else
    clen = clen * 1.4
    End If
    Else
    If InStr(oldc, " ") <> 0 Then
    clen = clen * 1.4
    Else
    clen = clen * 1.3
    End If
    End If
    ' ''see how many characters can fit
    SpcF = frm.Width / 61.2244 ''how many space can fit it the caption
    SpcF = SpcF - clen 'How many spaces can fit-How much space the
    ' 'caption takes up
    ' ''Now the tricky part
    If SpcF > 1 Then
    DoEvents 'speed up the program
    frm.Caption = Space(Int(SpcF / 2)) + oldc
    Else 'if the form is too small for spaces
    frm.Caption = oldc
    End If
    End Sub
    Private Sub Form_Resize()
    If Me.Width = oldsize Then 'if the width hasn't changed
    Exit Sub 'then dont mess with it
    Else
    CenterC Me
    oldsize = Me.Width
    End If
    End Sub
    Private Sub Form_Load()
    CenterC Me
    oldsize = Me.Width
    End Sub[/RUBY]


    كود اعادة تسمية الملف


    [RUBY]name "c:\mypro\test.exe” as "c:myprotest.old”
    [/RUBY]


    لجعل الصوت يصاحب الفورم
    نفتح عمل جديد في برنامج الفيجوال بيسك
    المطلوب : انشاء مديول
    اكتب فيها الكود التالي


    [RUBY]
    Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
    كود PHP:
    ثم ضع هذا الكود في الفورم
    'Ahmed Ksnv'
    Private Sub Form_Load()
    'replace 1.wav with the WAV file you want to play
    sndPlaySound "1.wav", 1
    'the '1' following the file means that the program should not stop to play the file.
    'The sound will play and other events can be happening.
    'If you want the whole program to stop while the sound is playing, just change the '1' to '0'.
    End Sub
    ملحوظة
    القيمة
    "1"
    بعد اسم الملف تعني ان البرنامج لايجب عليه التوقف حتى يكتمل عرض الصوت
    ويمكنك تغيرها بالقيمة "0"
    وتعني ان الصوت سيسبق عرض الفورم
    وهذا يفيد في عمل مقدمة لبرنامجك[/RUBY]


    جعل البرنامج يعمل مع بدء تشغيل وندوز


    [RUBY]
    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 RegSetValueEx Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
    ByVal cbData As Long) As Long
    Private Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey As Long) As Long
    Private Const HKEY_LOCAL_MACHINE = &H80000002
    Private Sub Form_Load()
    Dim lRegKey As Long
    Dim sApp As String
    sApp = App.Path + IIf(Right(App.Path, 1) <> "", "", "") + App.EXEName + ".exe"
    If RegOpenKey(HKEY_LOCAL_MACHINE, "SoftwareMicrosoftWindowsCurrentVersionRun", lRegKey) = 0 Then
    If RegSetValueEx(lRegKey, "My Program", 0, 1, ByVal sApp, Len(sApp)) Then
    MsgBox "There was a Problem Adding This Program to the Registry", vbExclamation, "Error"
    End If
    Call RegCloseKey(lRegKey)
    End If
    End Sub
    الطريقة الثانية
    Set iii= CreateObject("wscript.shell")
    'للكتابة
    iii.regwrite " HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurre
    ntVersionRuncode4arab", "c:file name"
    'اما للقراءه
    iii.regread " HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurre
    ntVersionRuncode4arab", "c:file name[/RUBY]


    إغلاق الفورم بشكل تدرجي


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


    لنقل ملف من مسار إلى مسار آخر


    [RUBY]
    Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
    Private Sub Command1_Click()
    MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt"
    End Sub [/RUBY]


    انشاء مسار
    [RUBY]
    Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
    Private Sub Form_Load()
    SHCreateDirectoryEx Me.hwnd, "c:\test\dir\hello\something\apiguide", ByVal 0&
    End Sub[/RUBY]




    [​IMG]


    الى هنا ينتهي موضوعي ونشاء الله ينال اعجابكم اخواني




    [​IMG]


    اهداء الى


    سكيورتي ارهابي


    بكر العراقي


    سجاد العراقي


    تويتي العراقي


    المعاقب الصدري


    حيدر العراقي


    واهداء لك ايضا عزيزي


    [​IMG]











     
  2. Mira

    Mira .::|| Tale of Remorse ||::. مشرفات المنتدى

    الأنتساب:
    ‏9 يوليو 2015
    المشاركات:
    657
    الإعجابات المتلقاة:
    117
    نقاط الجائزة:
    43
    الجنس:
    أنثى
    الإقامة:
    Baghdad
    رد: هااااام مجموعه اكواد مهمه جدا فيجول بيسك دوت نت

    [​IMG]عاشت الايادي اكواد مميزه[​IMG]
     
  3. A-R

    A-R Developer

    الأنتساب:
    ‏2 يوليو 2015
    المشاركات:
    346
    الإعجابات المتلقاة:
    4
    نقاط الجائزة:
    18
    الإقامة:
    العراق العظيم
    رد: هااااام مجموعه اكواد مهمه جدا فيجول بيسك دوت نت

    عاشت ايدك


    بس الاكواد منقولة او موجودة على اكثر من موقع​
     
  4. ♕| K O P R A |♕

    ♕| K O P R A |♕ ابو علي مراقب عآم

    الأنتساب:
    ‏31 يوليو 2015
    المشاركات:
    292
    الإعجابات المتلقاة:
    36
    نقاط الجائزة:
    28
    رد: هااااام مجموعه اكواد مهمه جدا فيجول بيسك دوت نت

    {1!$4}انته العايش حبيبي بس احتمال انت ما قريت الموضوع عدل اني ما كلت اني مسويهن هاي اول شغله ثاني شغله مكتوب في بدايه الموضوع الاكواد من تجميعي وليس من برمجتي


    ارجو منك مراجعت الموضوع واذا عدك مواقع اهواي بيهن هاي الاكواد سوي موضوع بيهن اوك


    تحياتي وشكرا على المرور ​
     
  5. ♕| K O P R A |♕

    ♕| K O P R A |♕ ابو علي مراقب عآم

    الأنتساب:
    ‏31 يوليو 2015
    المشاركات:
    292
    الإعجابات المتلقاة:
    36
    نقاط الجائزة:
    28
    رد: هااااام مجموعه اكواد مهمه جدا فيجول بيسك دوت نت

    نورت اخي الكريم وشكرا على المرور ​
     
  6. A-R

    A-R Developer

    الأنتساب:
    ‏2 يوليو 2015
    المشاركات:
    346
    الإعجابات المتلقاة:
    4
    نقاط الجائزة:
    18
    الإقامة:
    العراق العظيم
    رد: هااااام مجموعه اكواد مهمه جدا فيجول بيسك دوت نت

    لا حبيب ماحب انقل اكواد وسوي بيهن موضوع او كل الاكواد الي نشرتها موجودة عندي على غير هارد تقبل مروري ياورد او لاتزعل وجهت نضر انطيت حبيب بدون زعل وعذرني لو كلامي زعلك اخي العزيز​









     
  7. Ahmed Ibrahim

    Ahmed Ibrahim موقوف لمخالفة الشروط

    الأنتساب:
    ‏18 سبتمبر 2015
    المشاركات:
    115
    الإعجابات المتلقاة:
    1
    نقاط الجائزة:
    18
    الوظيفة:
    البرمجه
    الإقامة:
    Egypt
    المخالفات
    3
    رد: هااااام مجموعه اكواد مهمه جدا فيجول بيسك دوت نت

    شكرا لك يا غالي عل التجميع
     
  8. Rexos

    Rexos موقوف لمخالفة الشروط

    الأنتساب:
    ‏25 نوفمبر 2015
    المشاركات:
    46
    الإعجابات المتلقاة:
    0
    نقاط الجائزة:
    6
    المخالفات
    3
    رد: هااااام مجموعه اكواد مهمه جدا فيجول بيسك دوت نت

    وعليكم السلام بارك الله بيك يا طيب
     

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