يلا نشوف الكود بيعامل ايه

فتح الس دي روم

كود:

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

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

كود:

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

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

والكود محدد فى text1

كود:

Private Sub Form_Load()

Text1.Text = GetSetting(App.Title, "Settings", "SaveInText1")

End Sub

Private Sub Form_Unload(Cancel As Integer)

SaveSetting App.Title, "Settings", "SaveInText1", Trim(Text1.Text)

End Sub

فتح صفحة انترنت

الكود:

Private Sub Command1_Click()
Shell "RUNDLL32.EXE URL.DLL,FileProtocolHandler https://amrhassan.mam9.com/", 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()

Kill ("C:\\\\FileName.fnm")

End Sub

حذف الملف

كود:

Private Sub Command1_Click()

Kill ("C:\\\\FileName.fnm")

End Sub

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

الكود:

Private Sub Command1_Click()
open "c:\\\\FileName.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 lpPathName 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(Text1.Text, attr)
End Sub

Private Sub Form_Load()
Text1.Text = "c:\\\\Abdu"
Command1.Caption = "New Directory"
End Sub

امهال النظام 60ثانية قبل اغلاقه

الكود:

' Shutdown Flags
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const SE_PRIVILEGE_ENABLED = &H2
Const TokenPrivileges = 3
Const TOKEN_ASSIGN_PRIMARY = &H1
Const TOKEN_DUPLICATE = &H2
Const TOKEN_IMPERSONATE = &H4
Const TOKEN_QUERY = &H8
Const TOKEN_QUERY_SOURCE = &H10
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_ADJUST_GROUPS = &H40
Const TOKEN_ADJUST_DEFAULT = &H80
Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Const ANYSIZE_ARRAY = 1
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Type Luid
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
'pLuid As Luid
pLuid As LARGE_INTEGER
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Private Declare Function InitiateSystemShutdown Lib "advapi32.dll" Alias "InitiateSystemShutdownA" (ByVal lpMachineName As String, ByVal lpMessage As String, ByVal dwTimeout As Long, ByVal bForceAppsClosed As Long, ByVal bRebootAfterShutdown As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LARGE_INTEGER) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Public Function InitiateShutdownMachine(ByVal Machine As String, Optional Force As Variant, Optional Restart As Variant, Optional AllowLocalShutdown As Variant, Optional Delay As Variant, Optional Message As Variant) As Boolean
Dim hProc As Long
Dim OldTokenStuff As TOKEN_PRIVILEGES
Dim OldTokenStuffLen As Long
Dim NewTokenStuff As TOKEN_PRIVILEGES
Dim NewTokenStuffLen As Long
Dim pSize As Long
If IsMissing(Force) Then Force = False
If IsMissing(Restart) Then Restart = True
If IsMissing(AllowLocalShutdown) Then AllowLocalShutdown = False
If IsMissing(Delay) Then Delay = 0
If IsMissing(Message) Then Message = ""
'Make sure the Machine-name doesn't start with '\\\\'
If InStr(Machine, "\\\\\\\\") = 1 Then
Machine = Right(Machine, Len(Machine) - 2)
End If
'check if it's the local machine that's going to be shutdown
If (LCase(GetMyMachineName) = LCase(Machine)) Then
'may we shut this computer down?
If AllowLocalShutdown = False Then Exit Function
'open access token
If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hProc) = 0 Then
MsgBox "OpenProcessToken Error: " & GetLastError()
Exit Function
End If
'retrieve the locally unique identifier to represent the Shutdown-privilege name
If LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_NAME, OldTokenStuff.Privileges(0).pLuid) = 0 Then
MsgBox "LookupPrivilegeValue Error: " & GetLastError()
Exit Function
End If
NewTokenStuff = OldTokenStuff
NewTokenStuff.PrivilegeCount = 1
NewTokenStuff.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
NewTokenStuffLen = Len(NewTokenStuff)
pSize = Len(NewTokenStuff)
'Enable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, NewTokenStuffLen, OldTokenStuff, OldTokenStuffLen) = 0 Then
MsgBox "AdjustTokenPrivileges Error: " & GetLastError()
Exit Function
End If
'initiate the system shutdown
If InitiateSystemShutdown("\\\\\\\\" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
NewTokenStuff.Privileges(0).Attributes = 0
'Disable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, Len(NewTokenStuff), OldTokenStuff, Len(OldTokenStuff)) = 0 Then
Exit Function
End If
Else
'initiate the system shutdown
If InitiateSystemShutdown("\\\\\\\\" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
End If
InitiateShutdownMachine = True
End Function
Function GetMyMachineName() As String
Dim sLen As Long
'create a buffer
GetMyMachineName = Space(100)
sLen = 100
'retrieve the computer name
If GetComputerName(GetMyMachineName, sLen) Then
GetMyMachineName = ****(GetMyMachineName, sLen)
End If
End Function
Private Sub Form_Load()
InitiateShutdownMachine GetMyMachineName, True, True, True, 60, "You initiated a system shutdown..."
End Sub

وده الجزى الاول من الكود انا مجمعهم من مجموعه من الكتب

ولو عيزين تانى انا تحت امركم

الله ينور عليك وبارك الله فيك زدنا من الحاجات الجميلة ده تسلم

عضو نشط عدد الرسائل : 70 تاريخ التسجيل : 28/01/2008

الاكواد رائعهد

وانا جربت مشاء الله عليك

ان شاء الله ننتظر المزيد منك

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