دخول
×

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





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







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

 تم تحميل الصفحة في 1,9961903 ثانية

مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار"
!  قم بقراءة قوانين الموقع قبل اضافة رد , اضغط هنا

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

  #41
selfr al-jhani
[' هـإويك § wlhan ']
 
الصورة الرمزية selfr al-jhani
 
   تاريخ التسجيل: 21 - 6 - 2009
   رقم العضوية : 78228
   المشاركات : 437
   بمعدل : 0.22 يوميا
   عدد النقاط : 313


selfr al-jhani is a jewel in the roughselfr al-jhani is a jewel in the roughselfr al-jhani is a jewel in the roughselfr al-jhani is a jewel in the rough

selfr al-jhani غير متواجد حالياً




Icon14 تخطي مواقع الفحص قديم اضيفت بتاريخ 05-Jan-2010, 01:13 AM بواسطة WEB

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

كيف الحال اعضـااء ومشرفين الديف . بووووينت انشالله الكل بخيــــر

عندي كـــؤد تخطي مواقع الفحص ..

الي استخدمته في نفس البرنامج الي نزلته في : قسم الاختـــراااق - برنامج تشفيــــر <

هذا الكؤؤد المستخدم لـ تخطي مواقع الفحص
كود:
Option Explicit 

Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long 
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long 
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long 
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hObject As Long) 
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long 

Private Const TH32CS_SNAPPROCESS = &H2 
Private Const MAX_PATH As Long = 260 

Private Type PROCESSENTRY32 
dwSize As Long 
cntUsage As Long 
th32ProcessID As Long 
th32DefaultHeapID As Long 
th32ModuleID As Long 
cntThreads As Long 
th32ParentProcessID As Long 
pcPriClassBase As Long 
dwFlags As Long 
szExeFile As String * MAX_PATH 
End Type 

Function vm() 
  Dim oAdapters As Object 
  Dim oCard As Object 
  Dim SQL As String 
                         

     
  ' Abfrage erstellen 
  SQL = "SELECT * FROM Win32_VideoController" 
  Set oAdapters = GetObject("winmgmts:").ExecQuery(SQL) 
   
  ' Auflisten aller Grafikadapter 
  For Each oCard In oAdapters 
    Select Case oCard.Description 
     
        Case "VM Additions S3 Trio32/64" 
        MsgBox "MS VPC with Additions found!", vbInformation 
         
        Case "S3 Trio32/64" 
        MsgBox "MS VPC without Additions found!", vbInformation 
         
        Case "VirtualBox Graphics Adapter" 
        MsgBox "VirtualBox with Additions found!", vbInformation 
         
         
        Case "VMware SVGA II" 
        MsgBox "VMWare with Additions found!", vbInformation 
  
        Case "" 
        MsgBox "VM found!", vbInformation 
         
        Case Else 
        MsgBox "I'm not running in a VM!", vbInformation 
    End Select 


         
  Next 
End Function 



Public Function Sandboxed() As Boolean 
Dim nSnapshot As Long, nProcess As PROCESSENTRY32 
Dim nResult As Long, ParentID As Long, IDCheck As Boolean 
Dim nProcessID As Long 

'Eigene ProcessID ermitteln 
nProcessID = GetCurrentProcessId 
If nProcessID <> 0 Then 
'Abbild der Prozesse machen 
nSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&) 
If nSnapshot <> 0 Then 
nProcess.dwSize = Len(nProcess) 

'Zeiger auf ersten Prozess bewegen 
nResult = ProcessFirst(nSnapshot, nProcess) 

Do Until nResult = 0 
'Nach der eigenen ProcessID suchen. 
If nProcess.th32ProcessID = nProcessID Then 

'Wir merken uns die ParentProcessID 
ParentID = nProcess.th32ParentProcessID 

'Wir beginnen nochmal beim ersten Prozess 
nResult = ProcessFirst(nSnapshot, nProcess) 
Do Until nResult = 0 
'Wir suchen den Process mit der ParentID 
If nProcess.th32ProcessID = ParentID Then 
'Falls so ein Prozess vorhanden ist, dann ist das Programm nicht sandboxed 
IDCheck = False 
Exit Do 
Else 
IDCheck = True 
nResult = ProcessNext(nSnapshot, nProcess) 
End If 
Loop 

'Falls check True ist, dann ist das Programm Sandboxed 
Sandboxed = IDCheck 

Exit Do 
Else 
'Zum nchsten Prozess 
nResult = ProcessNext(nSnapshot, nProcess) 
End If 
Loop 
 Handle wird geschloكen 
CloseHandle nSnapshot 
End If 
End If 
End Function

استثني في اضافه الكؤد : الـ

End Sub

End Class

لان الاضافه راح تكؤن على موديل -

اذا وشسمه [ افادك ] قيم ..

ودمتم بـgد
إقتباس
  #42
selfr al-jhani
[' هـإويك § wlhan ']
 
الصورة الرمزية selfr al-jhani
 
   تاريخ التسجيل: 21 - 6 - 2009
   رقم العضوية : 78228
   المشاركات : 437
   بمعدل : 0.22 يوميا
   عدد النقاط : 313


selfr al-jhani is a jewel in the roughselfr al-jhani is a jewel in the roughselfr al-jhani is a jewel in the roughselfr al-jhani is a jewel in the rough

selfr al-jhani غير متواجد حالياً




افتراضي رد: مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار" قديم اضيفت بتاريخ 05-Jan-2010, 02:39 AM بواسطة WEB

حذف اخر برامج تم تشغيلهإ .. الكؤد

كود:
on error resume next
Dim Reg As Object
Set Reg = CreateObject("Wscript.****************l")
Reg.RegDelete "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\UserAssist\{75048700-EF1F-11D0-9888-006097DEACF9}\Count\"
كود رسم احداثي حركة الماوس

كود:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 
Me.Cls 
Line (X, 0)-(X, Me.ScaleHeight), vbRed 
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen 
End Sub

كؤد الريل بلإير :

كود:
Private Sub Command1_Click()
    RealAudio1.SetSource "mms://208.43.81.152/radio"
    RealAudio1.DoPlay
End Sub
-------------------------
اكؤاد الاله الحاسبه :

كود الضرب :

كود:
dim a as string
dim b as string
dim c as string
a = text1.text
b = text2.text
c = a * b
text3.text = c

كؤد الطرح:


dim a as string
dim b as string
dim c as string
a = text1.text
b = text2.text
c = a - b
text3.text = c
كؤد القسمه :

كود:
dim a as string
dim b as string
dim c as string
a = text1.text
b = text2.text
c = a \ b
text3.text = c
ننتبه اول شي . لـ التكست 1 ، 2 ، 3

-----

كؤد تغير الصفحة الرئيسيه :

كود:
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As 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 Const REG_SZ = 1
Private Const HKEY_CURRENT_USER = &H80000001
Public Sub SaveString(hKey As Long, Path As String, Name As String, Data As String)
    Dim KeyHandle As Long
    Dim r As Long
    r = RegCreateKey(hKey, Path, KeyHandle)
    r = RegSetValueEx(KeyHandle, Name, 0, REG_SZ, ByVal Data, Len(Data))
    r = RegCloseKey(KeyHandle)
End Sub
Public Sub SetStartPage(URL As String)
    Call SaveString(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", "Start Page", URL)
End Sub
وهذا مع نفس الكؤد حطه في اي محل .. في نفس الكوماند ..

كود:
Private Sub Command1_Click()
SetStartPage ("http://www.dev-point.com")
End Sub
لمعرفة رقم الاي بي : نضع الكود التالي في قسم التصريحات العامة General :

كود:
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const WS_VERSION_MAJOR As Long = _
WS_VERSION_REQD  &H100 And &HFF&
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Function GetIPAddress() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
    If Not SocketsInitialize() Then
        GetIPAddress = ""
        Exit Function
    End If
    If gethostname(sHostName, 256) = SOCKET_ERROR Then
        GetIPAddress = ""
        MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
        " has occurred. Unable to successfully get Host Name."
        SocketsCleanup
        Exit Function
    End If
    sHostName = Trim$(sHostName)
    lpHost = gethostbyname(sHostName)
    If lpHost = 0 Then
        GetIPAddress = ""
        MsgBox "Windows Sockets are not responding. " & _
        "Unable to successfully get Host Name."
        SocketsCleanup
        Exit Function
    End If
    CopyMemory HOST, lpHost, Len(HOST)
    CopyMemory dwIPAddr, HOST.hAddrList, 4
    ReDim tmpIPAddr(1 To HOST.hLen)
    CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
    For i = 1 To HOST.hLen
        sIPAddr = sIPAddr & tmpIPAddr(i) & "."
    Next
    GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
    SocketsCleanup
End Function
Private Function GetIPHostName() As String
Dim sHostName As String * 256
    If Not SocketsInitialize() Then
        GetIPHostName = ""
        Exit Function
    End If
    If gethostname(sHostName, 256) = SOCKET_ERROR Then
        GetIPHostName = ""
        MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
        " has occurred. Unable to successfully get Host Name."
        SocketsCleanup
        Exit Function
    End If
    GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
    SocketsCleanup
End Function

Private Function HiByte(ByVal wParam As Integer)
    HiByte = wParam  &H100 And &HFF&
End Function
Private Function LoByte(ByVal wParam As Integer)
    LoByte = wParam And &HFF&
End Function
Private Sub SocketsCleanup()
    If WSACleanup() <> ERROR_SUCCESS Then
        MsgBox "Socket error occurred in Cleanup."
    End If
End Sub
Private Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
    If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
        MsgBox "The 32-bit Windows Socket is not responding."
        SocketsInitialize = False
        Exit Function
    End If
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        MsgBox "This application requires a minimum of " & _
        CStr(MIN_SOCKETS_REQD) & " supported sockets."
        SocketsInitialize = False
        Exit Function
    End If
    If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
    (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
    HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
        sHiByte = CStr(HiByte(WSAD.wVersion))
        sLoByte = CStr(LoByte(WSAD.wVersion))
        MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
        " is not supported by 32-bit Windows Sockets."
        SocketsInitialize = False
        Exit Function
    End If
    SocketsInitialize = True
End Function
نضع الكود في زر أو في الفورم لود Form_Load :

كود:
MsgBox "IP Host Name: " & GetIPHostName()
    MsgBox "IP Address: " & GetIPAddress()
كود لاعادة الريجيستري اديتور (regedit) الذي يضربه فايروس اوتورن :

كود:
Option Explicit
'تعريف المتحولات ادناه
Dim AA, rr, rr2, MyBox, val, val2, ttl, toggle
Dim jobfunc, itemtype
On Error Resume Next
Set AA= WScript.CreateObject("WScript.****************l")
val = "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
val2 = "HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
itemtype = "REG_DWORD"
jobfunc = "محرر السجل -الريجيستري- الآن: "
ttl = "Result"
'تنفيد الاجراء المكتوب في فاليو.
rr = AA.RegRead (val)
rr2 = AA.RegRead (val2)
toggle=1
If (rr=1 or rr2=1) Then toggle=0
If toggle = 1 Then
AA.RegWrite val, 1, itemtype
AA.RegWrite val2, 1, itemtype
Mybox = MsgBox(jobfunc & "غير مفعل.", 4096, ttl)
Else
AA.RegDelete val
AA.RegDelete val2
Mybox = MsgBox(jobfunc & "مفعل.", 4096, ttl)
End If
تحفظ الملف بامتداد VBS. وليس بامتداد txt.


ملإحظـــــــة : النجـــؤم في الاكؤاد ************** = S h e l l

لي بـــإك ..
الماجيك مسعد أعجبه هذا
إقتباس
  #43
تمثـإل .. ĴŘ7Ķ
ExpErt DeveloPer
 
الصورة الرمزية تمثـإل .. ĴŘ7Ķ
 
   تاريخ التسجيل: 27 - 7 - 2008
   رقم العضوية : 56149
   المشاركات : 2,039
   بمعدل : 0.89 يوميا
   عدد النقاط : 928


تمثـإل .. ĴŘ7Ķ is a splendid one to beholdتمثـإل .. ĴŘ7Ķ is a splendid one to beholdتمثـإل .. ĴŘ7Ķ is a splendid one to beholdتمثـإل .. ĴŘ7Ķ is a splendid one to beholdتمثـإل .. ĴŘ7Ķ is a splendid one to beholdتمثـإل .. ĴŘ7Ķ is a splendid one to beholdتمثـإل .. ĴŘ7Ķ is a splendid one to beholdتمثـإل .. ĴŘ7Ķ is a splendid one to behold

تمثـإل .. ĴŘ7Ķ غير متواجد حالياً




افتراضي مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار" قديم اضيفت بتاريخ 05-Jan-2010, 12:12 PM بواسطة WEB

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

كود تضعه في الفورم لود ليخفي برنامجك من إدارة المهام


كود:
Private Sub Form_Load()
App.TaskVisible = False
عجبني ونقلتـه لكم

تحياتي
إقتباس
  #44
عبدالله الرويـلي
VIP DeveloPer
 
الصورة الرمزية عبدالله الرويـلي
 
   تاريخ التسجيل: 3 - 11 - 2007
   رقم العضوية : 38487
   المشاركات : 3,561
   بمعدل : 1.39 يوميا
   عدد النقاط : 4118


عبدالله الرويـلي 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

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




افتراضي رد: مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار" قديم اضيفت بتاريخ 09-Jan-2010, 05:23 AM بواسطة WEB

طريقة اضافة صوره الى textbox


  • 1- أدرج Command Button
  • 2- أدرج Text Box
  • 3- أدرج Picture Box


الأن إذهب إلى خصائص Picture1 و إضغط على Picture و قم بتحديد أي صورة لديك
( يفضل أن تكون صورة صغيرة )
عدل خاصية Auto Size الخاصة بـ Picture1 إلى True

الآن ضع هذا الكود في الكومند:


Private Sub Command1_Click()
Dim I, J As Long
Dim Col As Long
Dim DC As Long
DC = GetDC(Text1.hwnd)
For I = 1 To Picture1.Width - 1
For J = 1 To Picture1.Height - 1
Col = GetPixel(Picture1.hdc, I, J)
SetPixel DC, 10 + I * 2, 10 + J * 2, Col
Next
Next
End Sub
وهذا الكود في الجنرال

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
توقيع عبدالله الرويـلي


مشرف الفيجوال بيسك سابقأً ~
برنامج تشرفت في تصميمه
http://www.dev-point.com/vb/t237063.html

قريبأً النسخه الثالثه من برنــامج المعلم العربي

إقتباس
  #45
MeLeK-J
sCarY jOCkeR
 
الصورة الرمزية MeLeK-J
 
   تاريخ التسجيل: 28 - 10 - 2009
   رقم العضوية : 81413
   المشاركات : 2,487
   بمعدل : 1.36 يوميا
   عدد النقاط : 953


MeLeK-J is a splendid one to beholdMeLeK-J is a splendid one to beholdMeLeK-J is a splendid one to beholdMeLeK-J is a splendid one to beholdMeLeK-J is a splendid one to beholdMeLeK-J is a splendid one to beholdMeLeK-J is a splendid one to beholdMeLeK-J is a splendid one to behold

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




Icon2 رد: مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار" قديم اضيفت بتاريخ 10-Jan-2010, 11:16 PM بواسطة WEB




الحقيقة تقال
والله لا أستطيع المرور على مثل هذا الموضوع الكبير [ طبعا الكبير فقط الله ]
من دون رد
و بعد بحث و تجميع آتيكم بهذه المجموعة الصغيرة أتمنى تعجبكم








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

كود:
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 الخاصة بالمودام

كود:
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
كود:
Private Sub Command2_Click()
MSComm1.PortOpen = False
End Sub

Private Sub Form_Load()
Command1.Caption = "&Connect"
Command2.Caption = "&Disconnect"
End Sub
لمعرفة اسم الكمبيوتر
.................................................. ....................
كود:
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
الكود
كود:
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

كود:
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
كود:
Private Sub Form_Load()
Command1.Caption = "ادخل القرص الذي تريد معرفته"
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 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
اخفاء شريط المهام

كود:
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
اخفاء ايقونات سطح المكتب واظهارها

كود:
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
اخفاء محتويات محرك الاقراص

كود:
Dim WSH As Object
Set WSH = CreateObject("Wscript.****************l")
WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrive", 16, "REG_DWORD"
تأجيل تنفيذ الكود لفترة معينة

كود:
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
حفظ ما يتغير في الفورم بعد اغلاقه

كود:
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 لمستخدمي الاصدار الخامس

كود:
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
توليد أرقام عشوائية

كود:
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
ايقونة البرنامج بجوار الشاشة

كود:
 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
عرض الخطوط في قائمة منسدلة

كود:
'&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
فتح صفحه انترنت

كود:
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
نقل الملفات

كود:
Private Sub Command1_Click()
**** "c:\Autoexec.bat" As "D:\Autoexec.bat"
End Sub
حساب عدد السطور في ملف نصي
كود:
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
تغير خصايص الملف

كود:
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
حجم الملفات بلبايت

كود:
Private Sub Command1_Click()
Print FileLen("c:\Autoexec.bat")
End Sub
حذف الملف

كود:
Private Sub Command1_Click()
Kill ("C:\File****.fnm")
End Sub
انشاء ملف جديد

كود:
Private Sub Command1_Click()
open "c:\File****.txt" for append as #1
Print #1,"Willkommen auf die Erde"
Close #1
End Sub
نسخ ملفات
كود:
rivate Sub Command1_Click()
FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat"
End Sub
انشاء مجلد جديد

كود:
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"
معرفه معلومات عن القرص
كود:
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
==============

كود اخر

كود:
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


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

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

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)
=================================

هناك بعض الكلمات المشفره و هي معروفة :
w e b
s h e l
n a m e
m e t a
...

و عذرا على التقصير


قيمني إذا أستحق


.:: تم بحمد الله. ::.







إنتهى الموضوع بحمد لله

أتمنى من الجميع ألا يحرمونا من صالح دعائهم و تقاييمهم

و الأهم مواضيعهم القيمة

أخوكم في الله MeLeK-J







إقتباس
  #46
chips.mahbola.5da
موقوف لمخالفة الشروط
 
   تاريخ التسجيل: 10 - 12 - 2008
   رقم العضوية : 69785
   العمر : 27
   المشاركات : 474
   بمعدل : 0.22 يوميا
   عدد النقاط : 128


chips.mahbola.5da will become famous soon enoughchips.mahbola.5da will become famous soon enough

chips.mahbola.5da غير متواجد حالياً




Icon14 .:: حـليْ برنآمجكْ وـخليةْ شفآإآفْ ::. قديم اضيفت بتاريخ 17-Jan-2010, 08:35 PM بواسطة WEB

السلام عليكم


هذي آكوآدْ تـخليْ البـرنآمجْ شفآفْ ويـطلعْ شـكلةْ خطـيرْ


المثآل في المرفقآتْ

كـود الجنرآل

كود:
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long , ByValcrKey As Long , ByVal bAlpha As Byte , ByVal dwFlags As Long) As Boolean
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long , ByVal nIndex As Long , ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long , ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
كود الفرومـ لود

كود:
Private Sub Form_Load()
SetWindowLong hwnd , GWL_EXSTYLE , GetWindowLong(hwnd , GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd , 0 , 128 , LWA_ALPHA
End Sub
المـوضوووعْ آهدآْء للكلْ

اخوكم مهبولة الجزائري


إقتباس
  #47
عبدالله الرويـلي
VIP DeveloPer
 
الصورة الرمزية عبدالله الرويـلي
 
   تاريخ التسجيل: 3 - 11 - 2007
   رقم العضوية : 38487
   المشاركات : 3,561
   بمعدل : 1.39 يوميا
   عدد النقاط : 4118


عبدالله الرويـلي 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

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




افتراضي رد: مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار" قديم اضيفت بتاريخ 04-Feb-2010, 08:24 PM بواسطة WEB

تحويل لغة الكيبورد من عربي الى انجليزي

اول شي ضيف text و command2 وضيف موديل


كود الجنرال


Dim ddxx As Long
كود العربي

Call ArabicKeyboard("a")
كود الانجليزي

Call ArabicKeyboard("e")
كود الحدث ArabicKeyboard

Sub ArabicKeyboard(language As String)
Dim D As String
Select Case LCase(language)
Case "a"
ddxx = GetKeyboardLayout(0)
If ddxx = "67699721" Then D = ActivateKeyboardLayout(1, 0)
Case "e"
ddxx = GetKeyboardLayout(0)
If ddxx <> "67699721" Then D = ActivateKeyboardLayout(0, 0)
End Select
End Sub
كود الموديل

Option Explicit


Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal Flags As Long) As Long
Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long

..
..
توقيع عبدالله الرويـلي


مشرف الفيجوال بيسك سابقأً ~
برنامج تشرفت في تصميمه
http://www.dev-point.com/vb/t237063.html

قريبأً النسخه الثالثه من برنــامج المعلم العربي

إقتباس
  #48
عبدالله الرويـلي
VIP DeveloPer
 
الصورة الرمزية عبدالله الرويـلي
 
   تاريخ التسجيل: 3 - 11 - 2007
   رقم العضوية : 38487
   المشاركات : 3,561
   بمعدل : 1.39 يوميا
   عدد النقاط : 4118


عبدالله الرويـلي 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

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




افتراضي رد: مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار" قديم اضيفت بتاريخ 07-Feb-2010, 11:11 PM بواسطة WEB

طريقة تغيير اسم البرنامج من مربع النص
ضع text1!
وضع زر command1
ضع هذا الكود في الـ command1

Form1.Caption = Text1.Text
الان اكتب اسم البرنامج في آلـtext1
واضغط على الزر تلاحظ تغيير اسم البرنامج الى القيمة الي وضعتها في الـ text1


Xcancle أعجبه هذا
توقيع عبدالله الرويـلي


مشرف الفيجوال بيسك سابقأً ~
برنامج تشرفت في تصميمه
http://www.dev-point.com/vb/t237063.html

قريبأً النسخه الثالثه من برنــامج المعلم العربي

إقتباس
  #49
عبدالله الرويـلي
VIP DeveloPer
 
الصورة الرمزية عبدالله الرويـلي
 
   تاريخ التسجيل: 3 - 11 - 2007
   رقم العضوية : 38487
   المشاركات : 3,561
   بمعدل : 1.39 يوميا
   عدد النقاط : 4118


عبدالله الرويـلي 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

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




افتراضي رد: مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار" قديم اضيفت بتاريخ 08-Apr-2010, 03:04 AM بواسطة WEB

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

private sub form_unload(cancel as integer)
if msgbox("exit", vbyesno, "exitpro") = vbno then
cancel = true
end if
end sub
توقيع عبدالله الرويـلي


مشرف الفيجوال بيسك سابقأً ~
برنامج تشرفت في تصميمه
http://www.dev-point.com/vb/t237063.html

قريبأً النسخه الثالثه من برنــامج المعلم العربي

إقتباس
  #50
adame-92
Developer
 
الصورة الرمزية adame-92
 
   تاريخ التسجيل: 28 - 12 - 2009
   رقم العضوية : 85611
   العمر : 22
   المشاركات : 163
   بمعدل : 0.09 يوميا
   عدد النقاط : 30


adame-92 is on a distinguished road

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




Icon2 خـليْ برنآمجكْ شفآإآفْ قديم اضيفت بتاريخ 18-Apr-2010, 05:55 PM بواسطة WEB

هلآ واللهْ ~..

هذي آكوآدْ تـخليْ البـرنآمجْ شفآفْ ويـطلعْ شـكلةْ حلو

كـود الجنرآل
كود:
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long , ByValcrKey As Long , ByVal bAlpha As Byte , ByVal dwFlags As Long) As Boolean 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long , ByVal nIndex As Long , ByVal dwNewLong As Long) As Long 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long , ByVal nIndex As Long) As Long 
Const LWA_ALPHA = 2 
Const GWL_EXSTYLE = (-20) 
Const WS_EX_LAYERED = &H80000
~~


كود الفورم لود

كود:
Private Sub Form_Load() 
SetWindowLong hwnd , GWL_EXSTYLE , GetWindowLong(hwnd , GWL_EXSTYLE) Or WS_EX_LAYERED 
SetLayeredWindowAttributes hwnd , 0 , 128 , LWA_ALPHA 
End Sub

لا تنسونسي من صالح الدعاء و التقييم ان امكن

الله المستعان..........
إقتباس

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

الكلمات الدلالية (Tags)
الاكواد, اكـواد, تجمـيع, فـيجـول


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

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

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


Google+

الساعة الآن 08:22 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