موضوع: ممكن طلب ياجماعة,,,عاوز البرنامج دة

ردود: 12 | زيارات: 2171
  1. #1

    Red face ممكن طلب ياجماعة,,,عاوز البرنامج دة

    السلام عليكم
    انا اريد منكم طلب وهو
    عاوز برنامج Visual Studio 6.0
    ضرورى يخوانى الله يخليكم


  2. #2
    اخي العزيز هذه هدية بسيطة للترحيب بك كودات + كتب وانشاء الله سوف ارفع ملفاتVisual Studio 6.0 الى النت غداً مع تحياتي اخوك العزاوي
    السلام عليكم ورحمة الله وبركاته .
    ااكواد ووظائف في الفجول بيسك
    عالم الكودات+تصميم مساعد أوفيس المتحرك+ winsock+خدع
    للأتصال بالأنترنت باستخدام الdailup connection
    *كود برمجي*
    --------------------------------------------------------------------------------
    Option Explicit
    Private Sub Command1_Click()
    Dim X
    Dim DialUpConnectName As String
    'قم بتحديد اسم الاتصال الذي تود الاتصال به
    DialUpConnectName = "Sts"
    X = Shell("rundll32.exe rnaui.dll,RnaDial " & DialUpConnectName, 1)
    DoEvents
    'في حال اردت ارسال كلمة السر ايضا قم باضافتها في النص التالي قبل القوس الاول مباشرة
    '"123(enter)"
    SendKeys "{enter}", True
    DoEvents
    End Sub
    كود خاص لمعرفة كلمة السر لملفات Access 97
    *كود برمجي*
    --------------------------------------------------------------------------------
    Option Explicit
    Private zChar As String
    Dim n As Long, s1 As String * 1, s2 As String * 1
    Dim lsClave As String
    Dim mask As String


    Private Sub Command1_Click()
    ' يجب ان تضيف عنصر commonDialog الى برنامجك واسمه هنا DD
    DD.Filter = "Microsoft Access Database|*.mdb"
    DD.DefaultExt = "mdb"
    DD.ShowOpen
    zChar = DD.FileTitle
    mask = Chr(78) & Chr(134) & Chr(251) & Chr(236) & _
    Chr(55) & Chr(93) & Chr(68) & Chr(156) & _
    Chr(250) & Chr(198) & Chr(94) & Chr(40) & Chr(230) & Chr(19)
    Open zChar For Binary As #1
    Seek #1, &H42
    For n = 1 To 14
    s1 = Mid(mask, n, 1)
    s2 = Input(1, 1)
    If (Asc(s1) Xor Asc(s2)) <> 0 Then
    lsClave = lsClave & Chr(Asc(s1) Xor Asc(s2))
    End If
    Next
    Close 1
    MsgBox lsClave & "كلمة السر هــي"
    End Sub
    -------------------------------------------------------------------------------
    معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية)
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Declare Function GetTickCount Lib "Kernel32" () As Long

    Private Sub Command1_Click()
    MsgBox Format(GetTickCount, "0")
    End Sub
    --------------------------------------------------------------------------------
    كود لمعرفة كلمات السر على هيئة نجوم *****
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Type POINTAPI
    x As Long
    y As Long
    End Type
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Sub Timer1_Timer()
    Const EM_SETPASSWORDCHAR = &HCC
    Dim coord As POINTAPI
    'نقوم هنا بمعرفة احداثى الفأرة
    s = GetCursorPos(coord)
    x = coord.x
    y = coord.y
    'المكتوب بها كلمة المرور(textbox)نقوم هنا بمعرفة مقبض آداة التحرير
    h = WindowFromPoint(x, y)
    'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال
    Dim NewChar As Integer
    NewChar = CLng(0)
    retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
    End Sub
    --------------------------------------------------------------------------------
    كود لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر list
    *كود برمجي*
    -------------------------------------------------------------------------------
    Private Sub Form_Activate()
    Dim a As String
    Do While Not Data1.Recordset.EOF = True
    a = Data1.Recordset.Fields("name").Value
    ' هنا تمثل اسم الحقل في قاعدة البيانات name كلمة
    List1.AddItem a
    Data1.Recordset.MoveNext
    Loop
    End Sub
    --------------------------------------------------------------------------------
    كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(register) في البرامج المشهورة
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Form_Load()
    retvalue = GetSetting("A", "0", "Runcount")
    GD$ = Val(retvalue) + 1
    SaveSetting "A", "0", "RunCount", GD$
    If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل
    MsgBox "انتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية"
    Unload FRM '
    End If
    End Sub
    --------------------------------------------------------------------------------
    يقوم بتحويل شكل التكست واليبل الى 3d
    *كود برمجي*
    --------------------------------------------------------------------------------
    'Set form's AutoRedraw property toTrue
    Sub PaintControl3D(frm As Form, Ctl As Control)
    ' This Sub draws lines around controls to make them 3d

    ' darkgrey, upper - horizontal
    frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _
    Ctl.Width, Ctl.Top - 15), &H808080, BF
    ' darkgrey, left - vertical
    frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _
    Ctl.Top + Ctl.Height), &H808080, BF
    ' white, right - vertical
    frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _
    (Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF
    ' white, lower - horizontal
    frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _
    (Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF

    End Sub

    Sub PaintForm3D(frm As Form)
    ' This Sub draws lines around the Form to make it 3d

    ' white, upper - horizontal
    frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF
    ' white, left - vertical
    frm.Line (0, 0)-(0, frm.ScaleHeight), &HFFFFFF, BF
    ' darkgrey, right - vertical
    frm.Line (frm.ScaleWidth - 15, 0)-(frm.ScaleWidth - 15, _
    frm.Height), &H808080, BF
    ' darkgrey, lower - horizontal
    frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _
    frm.ScaleHeight - 15), &H808080, BF

    End Sub

    'DEMO USAGE
    'Add 1 label and 1 textbox

    Private Sub Form_Load()

    Me.AutoRedraw = True
    PaintForm3D Me
    PaintControl3D Me, Label1 'Label1 is name of label
    PaintControl3D Me, Text1 'Text1 is name of textbox

    End Sub
    ملاحظة في البداية لبد من انشاء تكست وليبل
    --------------------------------------------------------------------------------
    كود الاظهار النص بشكل عمودي
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Form_Activate()
    Dim s As String
    For i = 1 To Len(Label1)
    s = s & Mid$(Label1, i, 1) & vbCrLf
    Next
    Label1 = s
    End Sub
    --------------------------------------------------------------------------------
    كود تستطيع من خلاله حذف اي ملف
    *كود برمجي*
    --------------------------------------------------------------------------------
    قم بوضع هذا الكود في قسم جنرال
    Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
    ومن ثم حدد سار الملف مثال
    Private Sub Command1_Click()
    dim x
    x = DeleteFile("C:\WINDOWS\system\LZEXPAND.DLL")
    --------------------------------------------------------------------------------
    كود لاستدعاء ملف من نوع mid
    *كود برمجي*
    --------------------------------------------------------------------------------
    قم بوضع اداة
    mmcontrol1
    m و
    اجعل نامي
    Private Sub Form_Load()
    m.DeviceType = "sequencer"
    m.FileName = ("e:\Holiday3.mid")
    m.Command = "open"
    m.Command = "play"
    END SUB
    --------------------------------------------------------------------------------
    كود لتحميل فلاش من نوع SWF
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Form_Load()
    s.Movie = ("E:\Projects\Howl.swf")
    End Sub
    --------------------------------------------------------------------------------
    كود لوضع مقطع الفيديو في بكتشر
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Command1_Click()
    MM.HWNDDISPLAY=PICTURE1.HWND
    End Sub
    --------------------------------------------------------------------------------
    الزر الأيمن للماوس
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    IF BUTTON=2 THEN
    msgbox "الزر الأيمن للماوس"
    END IF
    End Sub
    --------------------------------------------------------------------------------
    لكتابة بس ارقام في تكست بوكس
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub COMMAND1_CLICK()
    DIM SS AS STRING
    SS="123456789"
    IF INSTR(SS,CHR(KEYASCII)=0 THEN
    KEYASCII=0
    END IF

    End Sub

    -------------------------------------------------------------------------------
    عمل مسح ملفات للقرص المرن
    *كود برمجي*
    --------------------------------------------------------------------------------
    kill"A:\*.*"


    --------------------------------------------------------------------------------
    عرض صندوق حوار Open With
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Command1_Click()
    Dim x As Long
    x = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL C:\vbzoom.log")
    End Sub
    --------------------------------------------------------------------------------
    حساب عدد سطور ملف نصى
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Command1_Click()
    Open "c:\autoexec.bat" For Input As #1
    Count:
    n = n + 1
    Line Input #1, x
    If EOF(1) Then
    Label1.Caption = n
    Exit Sub
    Else
    GoTo Count:
    End If
    Close
    End Sub
    --------------------------------------------------------------------------------
    فحص المنافذ
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Command1_Click()
    On Error GoTo opn:
    Winsock1.LocalPort = 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
    --------------------------------------------------------------------------------
    البرنامج يعمل على القرص المدمج (السيدي رووم) فقط
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long

    Private Sub Form_Load()
    Dim driveType As Long
    driveType = GetDriveType(Mid(App.Path, 1, 3))
    If driveType <> 5 Then
    'إنهاء البرنامج إذا كان لايشتغل من القرص المدمج
    End
    End If
    End Sub
    --------------------------------------------------------------------------------
    هذا كود لتشفير وفك تشفير نص
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Command1_Click()
    For i = 1 To Len(Text1.Text)
    st1 = Mid(Text1.Text, i, 1)
    as1 = Asc(st1)
    ch1 = Chr(255 - as1)
    st = st + ch1
    Next
    Text1.Text = st
    End Sub
    --------------------------------------------------------------------------------
    هذا الكود لإضافة عروض الفلاش لبرنامجك
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Command1_Click()
    Dim s As String
    s = App.Path
    If Mid(s, Len(s), 1) <> "\" Then s = s + "\"
    ShockwaveFlash1.Movie = s + "a4.swf"

    End Sub
    --------------------------------------------------------------------------------
    لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
    *كود برمجي*
    --------------------------------------------------------------------------------
    Dim startdate As String
    Dim differenceofdate
    Dim TRACEDATE As String
    Dim newdate
    Dim chk

    If GetSetting(App.Title, "Startup", "counter", "") = "" Then
    SaveSetting App.Title, "Startup", "counter", 1
    SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")
    SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")
    lblcnt.Caption = "1"

    ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then

    MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "

    End

    Else
    TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")
    chk = DateDiff("d", CDate(TRACEDATE), Now)
    If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.

    MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"

    End
    Else
    startdate = GetSetting(App.Title, "Startup", "Started", "")
    differenceofdate = DateDiff("d", startdate, Now)
    If differenceofdate <> 0 Then
    lblcnt.Caption = differenceofdate + 1
    SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")
    SaveSetting App.Title, "Startup", "counter", differenceofdate + 1
    End If
    If differenceofdate = 0 Then
    lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "")
    End If
    End If
    End If
    End Sub


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

  3. #3
    هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Command1_Click()
    'الوضع الطبيعي النسخ
    Picture2.PaintPicture Picture1.Picture, 0, 0, _
    Picture1.Width, Picture1.Height, 0, 0, _
    Picture1.Width, Picture1.Height, vbSrcCopy
    End Sub

    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
    -------------------------------------------------------------------------------
    كود لنسخ خلفية سطح المكتب إلى نموذجك
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Declare Function PaintDesktop Lib "user32" _
    (ByVal hdc As Long) As Long

    'انسخ هذ الكودالى حدث النقر في زر الامر
    Private Sub Command1_Click()
    PaintDesktop Form1.hdc
    End Sub
    --------------------------------------------------------------------------------
    تحويل اي حرف إلى حرف ASCII
    *كود برمجي*
    --------------------------------------------------------------------------------
    Dim temp as String
    temp=asc(text1.text)
    MsgBox temp
    -------------------------------------------------------------------------------
    تحيه حسب الوقت
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Form_Load()

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

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

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

    If Time >= "12:01 AM" Then
    MsgBox ("Good Morning YourNameHere!")
    End
    End If
    End Sub
    --------------------------------------------------------------------------------
    نوعية القرص (قرص مرن،سي دي،.....)
    *كود برمجي*
    -------------------------------------------------------------------------------
    'التصاريح
    Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
    Public Const DRIVE_CDROM = 5
    Public Const DRIVE_FIXED = 3
    Public Const DRIVE_RAMDISK = 6
    Public Const DRIVE_REMOTE = 4
    Public Const DRIVE_REMOVABLE = 2

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


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


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

    If rtn <> "" Then
    strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
    End If
    Next intCnt
    MsgBox (strMessage)
    --------------------------------------------------------------------------------
    مؤثر على الفورم
    *كود برمجي*
    -------------------------------------------------------------------------------
    Public Sub Pause(Duration As Long)
    '//i didn't write this so i can't docume
    ' nt it
    Dim Current As Long
    Current = Timer
    Do Until Timer - Current >= Duration
    DoEvents
    Loop
    End Sub
    Public Sub SlideRight(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does
    ' the transition
    SecondForm.Show '//show the form
    SecondForm.Top = FirstForm.Top '//make the .Top equal for both form
    SecondForm.Height = FirstForm.Height '//make the .Height equal
    SecondForm.Width = FirstForm.Width '//make the .Width equal
    SecondForm.Left = SecondForm.Width * -1 '//make .Left negative
    Do Until SecondForm.Left = 0
    '//do the loop until the form is all the
    ' way to the right
    SecondForm.Left = SecondForm.Left + 15 '//add 15 (duh)
    Pause 0.3 '//pause
    Loop
    End Sub

    Public Sub SlideDown(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does
    ' the transition
    SecondForm.Show '//show the form
    SecondForm.Top = FirstForm.Height * -1 'make .Top negative
    SecondForm.Height = FirstForm.Height '//make the .Height equal
    SecondForm.Width = FirstForm.Width '//make the .Width equal
    SecondForm.Left = FirstForm.Left '//make the .Left equal

    Do Until SecondForm.Top = 0
    '//do the loop until the form is all the
    ' way to the bottom
    SecondForm.Top = SecondForm.Top + 15
    Pause 0.3
    Loop
    End Sub

    Public Sub SlideLeft(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does
    ' the transition
    SecondForm.Show
    SecondForm.Top = FirstForm.Top
    SecondForm.Height = FirstForm.Height
    SecondForm.Width = FirstForm.Width
    SecondForm.Left = FirstForm.Width '//put on right side of screen

    Do Until SecondForm.Left = 0
    SecondForm.Left = SecondForm.Left - 15
    Pause 0.3
    Loop
    End Sub

    Public Sub SlideUp(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does
    ' the transition
    SecondForm.Show
    SecondForm.Top = FirstForm.Height '//put form to bottom of screen
    SecondForm.Height = FirstForm.Height
    SecondForm.Width = FirstForm.Width
    SecondForm.Left = FirstForm.Left

    Do Until SecondForm.Top = 0
    SecondForm.Top = SecondForm.Top - 15
    Pause 0.3
    Loop
    End Sub
    --------------------------------------------------------------------------------
    فورم دائري
    *كود برمجي*
    --------------------------------------------------------------------------------
    Sub formcircle (frm As Form, Size As Integer)

    For e% = Size% - 1 To 0 Step -1
    frm.Left = frm.Left - e%
    frm.Top = frm.Top + (Size% - e%)
    Next e%

    For e% = Size% - 1 To 0 Step -1
    frm.Left = frm.Left + (Size% - e%)
    frm.Top = frm.Top + e%
    Next e%

    For e% = Size% - 1 To 0 Step -1
    frm.Left = frm.Left + e%
    frm.Top = frm.Top - (Size% - e%)
    Next e%

    For e% = Size% - 1 To 0 Step -1
    frm.Left = frm.Left - (Size% - e%)
    frm.Top = frm.Top - e%
    Next e%
    End Sub
    --------------------------------------------------------------------------------
    تنزيل ملف من الانترنت
    *كود برمجي*
    --------------------------------------------------------------------------------
    'التصاريح
    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")
    -------------------------------------------------------------------------------
    --------------------------------------------------------
    اسم الكتاب : الفجوال بيسك دوت نت
    لغة البرمجه: الفجوال بيسك . نت VB.NET
    الـتـــحميـل: http://www.cb4a.com/book/programming/vbnet/vbnet.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : إحتراف الفجوال بيسك دوت نت
    لغة البرمجه: الفجوال بيسك . نت VB.NET
    الــتــحميـل: http://www.cb4a.com/book/programming/vbnet/masvbnet.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : واجهة برمجة التطبيقات (API)
    لغة البرمجه: الفجوال بيسك 6 VB
    الـــتـحميـل: http://www.cb4a.com/book/programming/vb6/api.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : برمجة الوسائط المتعددة بإستخدام DirectX
    لغة البرمجه: الفجوال بيسك 6 VB
    الــتــحميـل: http://www.cb4a.com/book/programming/vb6/dx.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : فجوال بيسك للجميع (متميز)
    لغة البرمجه: الفجوال بيسك 6 VB
    الـتـــحميـل: http://www.cb4a.com/book/programming/vb6/oop.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : التعامل مع مسجل النظام
    لغة البرمجه: الفجوال بيسك 6 VB
    الــتــحميـل: http://www.cb4a.com/book/programming/vb6/reg.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : كتاب رائع للفجوال بيسك
    لغة البرمجه: الفجوال بيسك 6 VB
    الـتـــحميـل: http://www.cb4a.com/book/programming/vb6/good.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : تعلم الفجوال بيسك 6 للمبتدئن
    لغة البرمجه: الفجوال بيسك 6 VB
    الـــتـحميـل: http://www.cb4a.com/book/programming/vb6/beg.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : قواعد البيانات في الفجوال بيسك 6
    لغة البرمجه: الفجوال بيسك 6 VB
    الـتـــحميـل: http://www.cb4a.com/book/programming/vb6/vbdatabase.htm
    ــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ
    اسم الكتاب : التعامل مع وسائط التخزين
    لغة البرمجه: الفجوال بيسك 6 VB
    الــتــحميـل: http://www.cb4a.com/book/programming/vb6/save.htm
    أسماء المجلدات الرئيسية والفرعية في قائمة
    *كود برمجي*
    --------------------------------------------------------------------------------
    'التصاريح
    Sub Listdir(path)
    Dim d(1000)
    Dir1.path = path
    For lop = 0 To Dir1.ListCount - 1
    d(cnt) = Dir1.List(lop)
    cnt = cnt + 1
    Next lop
    For lop = 0 To cnt - 1
    List1.AddItem d(lop)
    cur_depth = cur_depth + 1
    listdir d(lop)
    Next lop
    cur_depth = curr_depth - 1
    End Sub

    'الكود
    Listdir(اسم المجلد)

  4. #4
    --------------------------------------------------------------------------------
    كلام متحرك في TITLEBAR
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Timer1_Timer()
    On Error Resume Next
    If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
    Me.Caption = Right(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
    Timer1.Tag = Val(Timer1.Tag) + 1
    If Me.Caption = "" Then
    If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
    Me.Caption = Left(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
    Timer1.Tag = Val(Timer1.Tag) + 1
    End If
    End Sub
    Private Sub Form_Load()
    Timer1.Enabled = True
    End Sub
    --------------------------------------------------------------------------------
    فتح وغلق سواقة الأقراص
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Declare Function mciSendString Lib "winmm.dll" _
    Alias "mciSendStringA" _
    (ByVal lpstrCommand As String, _
    ByVal lpstrReturnString As String, _
    ByVal uReturnLength As Long, _
    ByVal hwndCallback As Long) As Long

    Public Sub EjectCD()
    Call mciSendString("set CDAudio Door Open Wait", 0&, 0&, 0&)
    bopen = True
    End Sub
    Public Sub CloseCD()
    Call mciSendString("set CDAudio Door Closed Wait", 0&, 0&, 0&)
    bopen = False
    End Sub
    'لفتح السواقة EjectCD
    'لغلق السواقة CloseCD
    --------------------------------------------------------------------------------
    مؤثر حلو على الفورم
    *كود برمجي*
    --------------------------------------------------------------------------------
    Function Dist(x1, y1, x2, y2) As Single
    Dim A As Single, B As Single
    A = (x2 - y1) * (x2 - x1)
    B = (y2 - y1) * (y2 - y1)
    Dist = Sqr(A +
    End Function
    Sub MoveIt(A, B, t)
    A = (1 - t) * A + t * B
    End Sub

    Private Sub Form_Click()
    Cls
    Dim t As Single, x1 As Single, y1 As Single
    Dim x2 As Single, y2 As Single, x3 As Single
    Dim y3 As Single, x4 As Single, y4 As Single

    Scale (-320, 200)-(320, -200)
    t = 0.05
    x1 = -320: y1 = 200
    x2 = 320: y2 = 200
    x3 = 320: y3 = -200
    x4 = -320: y4 = -200
    Do Until Dist(x1, y1, x2, y2) < 10
    Line (x1, y1)-(x2, y2)
    Line -(x3, y3)
    Line -(x4, y4)
    Line -(x1, y1)
    MoveIt x1, x2, t
    MoveIt y1, y2, t
    MoveIt x2, x3, t
    MoveIt y2, y3, t
    MoveIt x3, x4, t
    MoveIt y3, y4, t
    MoveIt x4, x1, t
    MoveIt y4, y1, t
    Loop
    End Sub

    Private Sub Form_Resize()
    Cls
    Dim t As Single, x1 As Single, y1 As Single
    Dim x2 As Single, y2 As Single, x3 As Single
    Dim y3 As Single, x4 As Single, y4 As Single

    Scale (-320, 200)-(320, -200)
    t = 0.05
    x1 = -320: y1 = 200
    x2 = 320: y2 = 200
    x3 = 320: y3 = -200
    x4 = -320: y4 = -200
    Do Until Dist(x1, y1, x2, y2) < 10
    Line (x1, y1)-(x2, y2)
    Line -(x3, y3)
    Line -(x4, y4)
    Line -(x1, y1)
    MoveIt x1, x2, t
    MoveIt y1, y2, t
    MoveIt x2, x3, t
    MoveIt y2, y3, t
    MoveIt x3, x4, t
    MoveIt y3, y4, t
    MoveIt x4, x1, t
    MoveIt y4, y1, t
    Loop
    End Sub
    --------------------------------------------------------------------------------
    اجعل برنامجك فوق الجميع always on top
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, ByVal X As Long, _
    ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, _
    ByVal wFlags As Long) As Long
    Private Const SWP_NOMOVE = 2
    Private Const SWP_NOSIZE = 1
    Private Const HWND_TOPMOST = -1
    Private Const HWND_NOTOPMOST = -2

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

    Private Sub Form_Load()
    SetOnTop Form1.hwnd, True
    End Sub
    --------------------------------------------------------------------------------
    هذا الكود لمنع تشغيل أكثر من نسخة من برنامجك
    *كود برمجي*
    --------------------------------------------------------------------------------
    Private Sub Form_Load()
    If App.PrevInstance = True Then
    MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
    Unload Me
    Exit Sub
    End If
    End Sub
    --------------------------------------------------------------------------------
    بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete
    *كود برمجي*
    --------------------------------------------------------------------------------
    'أضف مربعي نص وقائمة(لست بوكس)

    Const LB_FINDSTRING = &H18F
    Private Declare Function SendMessage Lib "User32" _
    Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Integer, _
    ByVal wParam As Integer, lParam As Any) As Long
    Private Sub Form_Load()
    List1.Clear
    List1.AddItem "abcd": List1.AddItem "acbd"
    List1.AddItem "bcde": List1.AddItem "bdef"
    List1.AddItem "cdef": List1.AddItem "cfde"
    Text1.Text = ""
    End Sub
    Private Sub Text1_Change()
    List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Text1.Text)
    End Sub
    --------------------------------------------------------------------------------
    أيضا يمكنك باستخدام الكود التالي معرفة عدد الكلمات في مربع النص
    *كود برمجي*
    --------------------------------------------------------------------------------
    Public Function GetWordCount(ByVal Text As String) As Long
    Text = Trim(Replace(Text, "-" & vbNewLine, ""))
    'Replace new lines with a single space
    Text = Trim(Replace(Text, vbNewLine, " "))
    'Collapse multiple spaces into one single space
    Do While Text Like "* *"
    Text = Replace(Text, " ", " ")
    Loop
    'Split the string and return counted words
    GetWordCount = 1 + UBound(Split(Text, " "))
    End Function
    --------------------------------------------------------------------------------
    تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
    *كود برمجي*
    --------------------------------------------------------------------------------
    diff= DateDiff("d", "22/1/2001", "22/1/2002")
    --------------------------------------------------------------------------------
    تأجيل تنفيذ الكود لفترة معينة
    *كود برمجي*
    --------------------------------------------------------------------------------
    Public Sub Delay(HowLong As Date)
    TempTime = DateAdd("s", HowLong, Now)
    While TempTime > Now
    DoEvents
    Wend
    End Sub

    Private Sub Command1_Click()
    Delay 5
    MsgBox "test"
    End Sub
    --------------------------------------------------------------------------------
    كود للأتصال من خلال البرنامج باستعمال اداة mscomm
    *كود برمجي*
    --------------------------------------------------------------------------------
    'اضف 12 command و 2 text و اداة mscomm و ضع الكود التالي
    Option Explicit

    Private Sub Command1_Click(Index As Integer)

    Text1.Text = Text1.Text & Command1(Index).Caption

    End Sub


    Private Sub Command2_Click()

    On Error GoTo er:

    Dim DialString$, FromModem$, dummy
    Dim Result As Long

    If MSComm1.PortOpen = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub

    If Text1.Text <> "" Then
    With MSComm1
    'تحديد منفذ الاتصال الخاص بالمودم
    .CommPort = Text2.Text
    'اعدادات خاصة بالمودم وسرعته
    .Settings = "9600,N,8,1"
    'فتح المنفذ للحصول على الخط
    .PortOpen = True
    'بعض الثوابت لتعريف الاتصال
    .Output = "ATDT" & MSComm1.Tag & Chr$(13)
    End With
    Else
    MsgBox "لايوجد رقم للأتصال به ؟", vbCritical, "خطاء"
    End If

    MSComm1.InBufferCount = 0

    'حلقة للحصول على نتائج الاتصال
    Do
    dummy = DoEvents()
    'تم اقفال منفذ الاتصال
    If MSComm1.PortOpen = False Then Exit Sub

    If MSComm1.InBufferCount Then
    FromModem$ = FromModem$ + MSComm1.Input

    If InStr(FromModem$, "NO DIALTONE") Then
    MsgBox "لايوجد صوت طنين تاكد من الخط غير مشغول او باتصاله بالمودم بشكل صحيح", vbInformation, ""
    Exit Do
    End If

    If InStr(FromModem$, "BUSY") Then
    MsgBox "الخط مشغول اعد الاتصال مرة اخرى", vbInformation, ""
    Exit Do
    End If

    If InStr(FromModem$, "OK") Then
    Result = MsgBox("ارفع السماعة واضغط موافق للمكالمة ان اردت انهاء المكالمة اضغط موافق بدون رفع السماعة", vbInformation, "")
    Exit Do
    End If
    End If
    Loop
    MSComm1.PortOpen = False

    Exit Sub
    er:
    If Err.Number = 8002 Then
    MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vbCritical, "خطاء"
    Else
    MsgBox Err.Number & " " & Err.Description, vbCritical, "خطاء"
    End If

    End Sub


    Private Sub Command3_Click()

    If MSComm1.PortOpen = False Then Exit Sub
    MSComm1.PortOpen = False

    End Sub
    --------------------------------------------------------------------------------
    تشغيل الصوت
    *كود برمجي*
    --------------------------------------------------------------------------------
    'فقط *.wav إظهار الملفات من النوع
    commonDialog1.Filter = "Wave Files|*.wav|"
    'لإضهار مربع حوار فتح
    CommonDialog1.ShowOpen
    'لو لم يختار أي ملف فإنه يتم الخروج من هذا الإجراء
    'دون فتح الملف
    ' FileName حيث أن اسم الملف يتواجد في الخاصية
    If CommonDialog1.FileName = "" Then Exit Sub

    'تحديد نوع الملف المطلوب تشغيله
    MMControl1.DeviceType = "waveaudio"
    'تحديد اسم ملف الصوت
    MMControl1.FileName = CommonDialog1.FileName
    'فتح ملف الصوت
    MMControl1.Command = "open
    --------------------------------------------------------------------------------
    امر بحث عن الملفات
    *كود برمجي*
    --------------------------------------------------------------------------------
    'ضع هذا الكود في ملف باس bas
    Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _
    (ByVal lpRootPath As String, _
    ByVal lpInputName As String, _
    ByVal lpOutputName As String) As Long

    Public Const MAX_PATH = 260
    Public Function FindFile(RootPath As String, _
    FileName As String) As String

    Dim lNullPos As Long
    Dim lResult As Long
    Dim sBuffer As String

    On Error GoTo FileFind_Error

    'Allocate buffer
    sBuffer = Space(MAX_PATH * 2)

    'Find the file
    lResult = SearchTreeForFile(RootPath, FileName, sBuffer)

    'Trim null, if exists
    If lResult Then
    lNullPos = InStr(sBuffer, vbNullChar)
    If Not lNullPos Then
    sBuffer = Left(sBuffer, lNullPos - 1)
    End If
    'Return filename
    FindFile = sBuffer
    Else
    'Nothing found
    FindFile = vbNullString
    End If

    Exit Function

    FileFind_Error:
    FindFile = vbNullString

    End Function

    'البحث عن ملف
    'هذا الكود ضعه في الحدث الضغط على زر كوماند او غيره
    MsgBox FindFile("c:\", "win.com")

    --------------------------------------------------------------------------------
    هل الملف موجود أم لا؟
    *كود برمجي*
    -------------------------------------------------------------------------------
    If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
    Msgbox "الملف غير موجود"
    Else
    Msgbox "الملف موجود"
    End If


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

  5. #5
    اخي العزيز هذا ربط فجول بيسك
    http://www.montada.com/showthread.php?t=442815

  6. #6

    Red face شكراً اخى العزيز

    شكراً يا غالى جداً على هة الاكواد الجميلة
    وشكراً على البرنامج برضة
    وياريت تجيب دروس بقى للمنتدى ومزيد من الآكواد
    شكراً اخى هيثم

  7. #7

    Red face على فكرة

    [quote=هاني وميثم]اخي العزيز هذا ربط فجول بيسك
    http://www.montada.com/showthread.php?t=442815[/quote]
    على فكرة يا غغالى البرنامج مش شغال
    ياريت تجيبلى البرنمج من منتدى تانى لانى الصراحة انا زعلت اوى ونفسى فى البرنامجة دة
    ضـــــــــــــــــــــرورى

  8. #8
    [quote=طالب^العلم]
    اقتباس الموضوع الأصلي كتب بواسطة هاني وميثم
    اخي العزيز هذا ربط فجول بيسك
    http://www.montada.com/showthread.php?t=442815[/quote]
    على فكرة يا غغالى البرنامج مش شغال
    ياريت تجيبلى البرنمج من منتدى تانى لانى الصراحة انا زعلت اوى ونفسى فى البرنامجة دة
    ضـــــــــــــــــــــرورى
    هيا الوصلة اللى جوة شغالة والبرنامج بيححمل لكن فى عيب فى البرنامج

  9. #9
    اخي العزيز ماهو العيب في اللغة الرجاء التوضيح لحل المشكلة نشاء الله

  10. #10
    اخي العزيز هذا ربط جديد
    http://www.upload2.net/download2/U5L...art01.rar.html
    الملف الثاني
    http://www.upload2.net/download2/ocw...art02.rar.html
    الملف اثالث
    http://www.upload2.net/download2/70n...art03.rar.html
    الملف الرابع
    http://www.upload2.net/download2/ZZp...art04.rar.html
    الملف الخامس
    http://www.upload2.net/download2/Qr3...art05.rar.html
    الملف السادس
    http://www.upload2.net/download2/Hyu...art06.rar.html
    الملف السابع
    http://www.upload2.net/download2/B2d...art07.rar.html
    الملف الثامن
    http://www.upload2.net/download2/u8A...art08.rar.html
    الملف التاسع
    http://www.upload2.net/download2/vOk...ion.part09.rar.
    كلمة السر لفك ضغط البرنامج
    alsaboodi

    السيريال
    بداخل ملف البرنامج

    تحياتي

  11. #11

    Red face بــًص يا غالى

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

  12. #12

Bookmarks

قوانين الموضوعات

  • لا يمكنك اضافة موضوع جديد
  • لا يمكنك اضافة ردود
  • لا يمكنك اضافة مرفقات
  • لا يمكنك تعديل مشاركاتك
  •  
  • كود BB مفعّل
  • رموز الحالة مفعّل
  • كود [IMG] مفعّل
  • [VIDEO] code is مفعّل
  • كود HTML معطل