دخول
×

حسابٌ واحد لجميع خدماتنا !





إنشاء حساب
نقطة التطوير - dev-point.com







قسم فيجوال بيسك 6 و ما قبله للدروس و الشروحات الخاصه بـ Visual Basic 6 وما قبله . . .

 تم تحميل الصفحة في 0,1851925 ثانية
!  قم بقراءة قوانين الموقع قبل اضافة رد , اضغط هنا

LinkBack أدوات الموضوع انواع عرض الموضوع

  #1
محمد الفسكاوى
Developer
 
الصورة الرمزية محمد الفسكاوى
 
   تاريخ التسجيل: 20 - 7 - 2009
   رقم العضوية : 79895
   المشاركات : 323
   بمعدل : 0.17 يوميا
   نظام التشغيل : Windows XP
   عدد النقاط : 146


محمد الفسكاوى will become famous soon enoughمحمد الفسكاوى will become famous soon enough

محمد الفسكاوى غير متواجد حالياً




Icon11 مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت قديم اضيفت بتاريخ 20-Oct-2009, 07:48 PM بواسطة WEB

كيفكم اخوان

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


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

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


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

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

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

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

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

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

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

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

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

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


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

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

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

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


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

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

Private Sub Command1_Click()
OpenCDDriveDoor (True)
End Sub

Private Sub Command2_Click()
OpenCDDriveDoor (False)
End Sub

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


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

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClass**** As String, ByVal lpWindow**** As String) As Long

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long



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

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

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


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

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

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

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


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

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


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

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

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


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

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


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

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

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

startIndex = endIndex + Len(Delimiter)
Loop

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

return the array inside a Variant
Split = res()

End Function

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


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

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

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

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


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

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

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


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


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

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

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


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

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

نقل الملفات


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

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

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


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


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


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


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

حذف الملف


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

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


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



نسخ ملفات

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

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


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

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

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


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

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

Private Sub Form_Load()

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


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

كود اخر


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

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

للامانة الموضوع منقول
إقتباس
  #2
موجود
VIP DeveloPer
 
الصورة الرمزية موجود
 
   تاريخ التسجيل: 16 - 5 - 2008
   رقم العضوية : 50076
   المشاركات : 3,870
   بمعدل : 1.67 يوميا
   عدد النقاط : 4885


موجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond reputeموجود has a reputation beyond repute

موجود غير متواجد حالياً




افتراضي رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت قديم اضيفت بتاريخ 20-Oct-2009, 07:55 PM بواسطة WEB

اخوي لو تحطها داخـل مستند احسن
توقيع موجود

???? ????? ????????? ????? ??? ..??? ??? ??? ??????? ?? ????? ??? ???? ??? ?? ??? ????????? ???? ?????
????????

??????? ????? .. ????? ?? ?? ???????? .


إقتباس
  #3
محمد الفسكاوى
Developer
 
الصورة الرمزية محمد الفسكاوى
 
   تاريخ التسجيل: 20 - 7 - 2009
   رقم العضوية : 79895
   المشاركات : 323
   بمعدل : 0.17 يوميا
   نظام التشغيل : Windows XP
   عدد النقاط : 146


محمد الفسكاوى will become famous soon enoughمحمد الفسكاوى will become famous soon enough

محمد الفسكاوى غير متواجد حالياً




افتراضي رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت قديم اضيفت بتاريخ 20-Oct-2009, 07:55 PM بواسطة WEB

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

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

Private Declare Function GetTickCount Lib "Kernel32" () As Long
Private Sub Command1_Click()
MsgBox Format(GetTickCount, "0")
End Sub

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

كود لمعرفة كلمات السر على هيئة نجوم *****
*كود برمجي*

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

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub Timer1_Timer()
Const EM_SETPASSWORDCHAR = &HCC
Dim coord As POINTAPI
'نقوم هنا بمعرفة احداثى الفأرة
s = GetCursorPos(coord)
x = coord.x
y = coord.y
'المكتوب بها كلمة المرور(****box)نقوم هنا بمعرفة مقبض آداة التحرير
h = WindowFromPoint(x, y)
'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال
Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub

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

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

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

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

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

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

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

Private Sub Form_Load()
retvalue = GetSetting("A", "0", "Runcount")
GD$ = Val(retvalue) + 1
SaveSetting "A", "0", "RunCount", GD$
If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل
MsgBox "انتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية"
Unload FRM '
End If
End Sub

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

قم بوضع اداة
mmcontrol1

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

kill"A:\*.*"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Private Sub Form_Load()

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

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

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

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

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

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

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

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

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

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

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

If rtn <> "" Then
strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
End If
Next intCnt
MsgBox (strMessage)
=================================
إقتباس
  #4
وليد الشمري
أستغفر الله
 
الصورة الرمزية وليد الشمري
 
   تاريخ التسجيل: 4 - 7 - 2009
   رقم العضوية : 78951
   المشاركات : 1,396
   بمعدل : 0.73 يوميا
   عدد النقاط : 2852


وليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond repute

وليد الشمري غير متواجد حالياً




افتراضي رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت قديم اضيفت بتاريخ 20-Oct-2009, 08:03 PM بواسطة WEB

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

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

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

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

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

هذا الموضوع

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

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

اسدحها هنا مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار"


تقبل فائق احترامي
توقيع وليد الشمري

إقتباس
  #5
محمد الفسكاوى
Developer
 
الصورة الرمزية محمد الفسكاوى
 
   تاريخ التسجيل: 20 - 7 - 2009
   رقم العضوية : 79895
   المشاركات : 323
   بمعدل : 0.17 يوميا
   نظام التشغيل : Windows XP
   عدد النقاط : 146


محمد الفسكاوى will become famous soon enoughمحمد الفسكاوى will become famous soon enough

محمد الفسكاوى غير متواجد حالياً




افتراضي رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت قديم اضيفت بتاريخ 20-Oct-2009, 08:09 PM بواسطة WEB

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

سكون فى مكتبة اكواد الفجول بيزك
إقتباس
  #6
وليد الشمري
أستغفر الله
 
الصورة الرمزية وليد الشمري
 
   تاريخ التسجيل: 4 - 7 - 2009
   رقم العضوية : 78951
   المشاركات : 1,396
   بمعدل : 0.73 يوميا
   عدد النقاط : 2852


وليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond reputeوليد الشمري has a reputation beyond repute

وليد الشمري غير متواجد حالياً




افتراضي رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت قديم اضيفت بتاريخ 20-Oct-2009, 08:17 PM بواسطة WEB

ان شاء الله
توقيع وليد الشمري

إقتباس
  #7
مهند الانباري
Beginner Developer
 
الصورة الرمزية مهند الانباري
 
   تاريخ التسجيل: 17 - 3 - 2011
   رقم العضوية : 112243
   المشاركات : 138
   بمعدل : 0.11 يوميا
   عدد النقاط : 10


مهند الانباري is on a distinguished road

مهند الانباري غير متواجد حالياً




افتراضي رد: مجموعه اكوااد فجول بيسك خطيرة الى احبابى فى الديف بوينت قديم اضيفت بتاريخ 28-Apr-2011, 12:17 AM بواسطة WEB

يعطيك العافية مبدع وروعه
إقتباس

مواقع النشر (المفضلة)

الكلمات الدلالية (Tags)
مجموعه, الديف, احبابي, اكوااد, بيسك, بوينت, خطيرة, فجول


الذين يشاهدون محتوى الموضوع الآن : 1 ( الأعضاء 0 والزوار 1)
 
أدوات الموضوع
انواع عرض الموضوع

تعليمات المشاركة
لا تستطيع إضافة مواضيع جديدة
لا تستطيع الرد على المواضيع
لا تستطيع إرفاق ملفات
لا تستطيع تعديل مشاركاتك

BB code is في
كود HTML معطلة
Trackbacks are في
Pingbacks are في
Refbacks are في



الساعة الآن 10:38 AM

Powered by Devpoint, Inc. community
Copyrights for vBulletin Inc.
Devpoint v3.0 preview - Build 1402.11

نظام الترقية - الحسابات الموثوقة - خصوصية الموقع - [ Dev-PoinT ] - الأعلى




SEO by vBSEO 3.6.0 PL2 ©2011, Crawlability, Inc.

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180