lFileSize = FileLen(strFileName)
اذا تبغى الحجم بالكيلو بايت اقسم على 1024

WinDir$ = Environ$("windir")
KillWin$ = WinDir$ + "\Rundll.exe User.exe,ExitWindows"
Shell KillWin$

Dim cPrinter As Printer
For Each cPrinter In Printers
Print Printer.DeviceName
Next

If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل اثر من نسخه في نفس الوقت"
UnLoad Me
Exit Sub
End If

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = True
End Sub

Kill "c:\windows\desktop\vb\*.*"

shell "C:\WINDOWS\CALC.EXE

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type

Private Const WS_POPUP = &H80000000
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOPMOST = -1
Private Const DT_LEFT = &H0
Private Const DT_CALCRECT = &H400
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
ByVal lpClassName As String, ByVal lpWindowName _
As String, ByVal dwStyle As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight _
As Long, ByVal hWndParent As Long, ByVal hMenu As _
Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) 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 Declare Function GetDC Lib "user32" (ByVal _
hwnd As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal _
hhDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal _
hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crctolor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal _
hhDC As Long, lpRect As RECT, ByVal hBrush As Long) _
As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal _
hhDC As Long, ByVal crctolor As Long) As Long
Private Declare Function DrawText Lib "user32" Alias _
"DrawTextA" (ByVal hhDC As Long, ByVal lpStr As _
String, ByVal nCount As Long, lpRect As RECT, _
ByVal wFormat As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal _
hhDC As Long, Rct As RECT, ByVal edge As Long, ByVal _
grfFlags As Long) As Boolean

Private lng_hWnd As Long

Sub GetToolTipText(txt As String)
Dim hDC&, hBrush&, ClrInfo&
Dim pt As POINTAPI, Rct As RECT

ClrInfo = &HE1FFFF
If Not lng_hWnd Then
'انشاء أداة عنوان
lng_hWnd = CreateWindowEx(0, "STATIC", "", WS_POPUP, _
0, 0, 0, 0, hwnd, 0, App.hInstance, 0)
End If

'(الحصول على مقبض سياق الجهاز (منطقة الرسم
hDC = GetDC(lng_hWnd)
SetBkColor hDC, ClrInfo
'الحصول على أبعاد النص
DrawText hDC, txt, Len(txt), Rct, DT_CALCRECT
' الهوامش
Rct.Bottom = Rct.Bottom + 6
Rct.Right = Rct.Right + 6
GetCursorPos pt

'اظهار أداة العنوان في موقع المشيرة
SetWindowPos lng_hWnd, HWND_TOPMOST, pt.X - 5, pt.Y + 20, _
Rct.Right - Rct.Left, Rct.Bottom - Rct.Top, _
SWP_SHOWWINDOW Or SWP_NOACTIVATE
DoEvents

'الحصول على مقبض الفرشاه للتلوين
hBrush = CreateSolidBrush(ClrInfo)
FillRect hDC, Rct, hBrush
DeleteObject hBrush
'رسم الحواف البارزة
DrawEdge hDC, Rct, 1, BF_LEFT Or BF_RIGHT
DrawEdge hDC, Rct, 1, BF_TOP Or BF_BOTTOM
With Rct
.Left = .Left + 3: .Right = .Right - 3
.Top = .Top + 3: .Bottom = .Bottom - 3
End With
'رسم النص
DrawText hDC, txt, Len(txt), Rct, DT_LEFT
End Sub

Private Sub Form_Load()
Timer1.Interval = 50
End Sub

Private Sub Timer1_Timer()
If lng_hWnd Then
DestroyWindow lng_hWnd
End If
GetToolTipText "vb4arab"
End Sub

Option Explicit

Private Sub Command1_Click()
Dim X
Dim DialUpConnectName As String
'قم بتحديد اسم الاتصال الذي تود الاتصال به
DialUpConnectName = "Sts"
X = Shell("rundll32.exe rnaui.dll,RnaDial " & DialUpConnectName, 1)
DoEvents
'في حال اردت ارسال كلمة السر ايضا قم باضافتها في النص التالي قبل القوس الاول مباشرة
'"123(enter)"
SendKeys "{enter}", True
DoEvents
End Sub

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

Private Sub Command1_Click()
Dim x As Long
x = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL C:\vbzoom.log")
End Sub

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

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

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 Declare Function PaintDesktop Lib "user32" _
(ByVal hdc As Long) As Long

'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesktop Form1.hdc
End Sub

Sub formcircle (frm As Form, Size As Integer)


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


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


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


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

Private Sub Timer1_Timer()
On Error Resume Next
If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Right(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1


If Me.Caption = "" Then
If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Left(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1
End If
End Sub


Private Sub Form_Load()
Timer1.Enabled = True
End Sub

'ضع هذا الكود في ملف باس bas
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _
(ByVal lpRootPath As String, _
ByVal lpInputName As String, _
ByVal lpOutputName As String) As Long

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

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

On Error GoTo FileFind_Error

'Allocate buffer
sBuffer = Space(MAX_PATH * 2)

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

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

Exit Function

FileFind_Error:
FindFile = vbNullString

End Function

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

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

Function Dist(x1, y1, x2, y2) As Single

Dim A As Single, B As Single

A = (x2 - y1) * (x2 - x1)

B = (y2 - y1) * (y2 - y1)

Dist = Sqr(A + B)

End Function

Sub MoveIt(A, B, t)

A = (1 - t) * A + t * B

End Sub



Private Sub Form_Click()

Cls

Dim t As Single, x1 As Single, y1 As Single

Dim x2 As Single, y2 As Single, x3 As Single

Dim y3 As Single, x4 As Single, y4 As Single



Scale (-320, 200)-(320, -200)

t = 0.05

x1 = -320: y1 = 200

x2 = 320: y2 = 200

x3 = 320: y3 = -200

x4 = -320: y4 = -200

Do Until Dist(x1, y1, x2, y2) < 10

Line (x1, y1)-(x2, y2)

Line -(x3, y3)

Line -(x4, y4)

Line -(x1, y1)

MoveIt x1, x2, t

MoveIt y1, y2, t

MoveIt x2, x3, t

MoveIt y2, y3, t

MoveIt x3, x4, t

MoveIt y3, y4, t

MoveIt x4, x1, t

MoveIt y4, y1, t

Loop

End Sub



Private Sub Form_Resize()

Cls

Dim t As Single, x1 As Single, y1 As Single

Dim x2 As Single, y2 As Single, x3 As Single

Dim y3 As Single, x4 As Single, y4 As Single



Scale (-320, 200)-(320, -200)

t = 0.05

x1 = -320: y1 = 200

x2 = 320: y2 = 200

x3 = 320: y3 = -200

x4 = -320: y4 = -200

Do Until Dist(x1, y1, x2, y2) < 10

Line (x1, y1)-(x2, y2)

Line -(x3, y3)

Line -(x4, y4)

Line -(x1, y1)

MoveIt x1, x2, t

MoveIt y1, y2, t

MoveIt x2, x3, t

MoveIt y2, y3, t

MoveIt x3, x4, t

MoveIt y3, y4, t

MoveIt x4, x1, t

MoveIt y4, y1, t

Loop

End Sub

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

وسأقوم بإضافة المزيد من الأكواد وملفات مفتوجة للفيجويل

وين التفاعل

أن شاء الله يا أخي "*Dr Jeeni*"

مشكور أخي "عيون الليل" على المرور

مشكور أخي "اكرم ابوسبيحة" على المرور وأعتقد أنه في موضوع مشروح في الساحة عن عمل ملف setup