Private Sub Command1_Click()
Dim Dday As Integer
Dday = Weekday(Date)
If Dday = 1 Then Print "الأحد"
If Dday = 2 Then Print "الاثنين"
If Dday = 3 Then Print "الثلاثاء"
If Dday = 4 Then Print "الأربعاء"
If Dday = 5 Then Print "الخميس"
If Dday = 6 Then Print "الجمعة"
If Dday = 7 Then Print "السبت"
End Sub

Private Sub Command1_Click()
Mmonth = Mid(Date, 4, 2)
Label1 = MonthName(Mmonth)
End Sub

Dim Llabel As Integer

Private Sub Form_Load()
Form1.ScaleMode = 3
Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
Llabel = Llabel + 10
Label1.Left = Llabel
If Llabel > 300 Then
Timer1.Interval = 0
Timer2.Interval = 100
End If
End Sub

Private Sub Timer2_Timer()
Llabel = Llabel - 10
Label1.Left = Llabel
If Llabel < 0 Then
Timer1.Interval = 100
Timer2.Interval = 0
End If
End Sub

Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32

Public Type RASCONN95
   dwSize As Long
   hRasCon As Long
   szEntryName(RAS95_MaxEntryName) As Byte
   szDeviceType(RAS95_MaxDeviceType) As Byte
   szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Type RASCONNSTATUS95
   dwSize As Long
   RasConnState As Long
   dwError As Long
   szDeviceType(RAS95_MaxDeviceType) As Byte
   szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Private Sub Command1_Click()
On Error GoTo Error:
Open "ضع مسار الملف الذي تريد التأكد من وجوده هنا" For Input As #1
Close
MsgBox ("الملف موجود")
Exit Sub
Error:
MsgBox ("الملف غير موجود")
End Sub

Private Sub Command1_Click()
Print FileLen("c:\Autoexec.bat")
End Sub

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Command1_Click()
Print Format(GetTickCount / 10000 / 6, "0")
End Sub

Private Sub Form_Load()
MMControl1.Visible = False
MMControl1.DeviceType = "sequencer"
MMControl1.FileName = ("c:\FileName.mid")
MMControl1.Command = "open"
MMControl1.Command = "play"
End Sub

Private Sub Form_Load()
MMControl1.FileName = ("c:\FileName.dat")
MMControl1.Command = "open"
MMControl1.hWndDisplay = Picture1.hWnd
End Sub

Private Sub Command1_Click()
Kill ("C:\FileName.fnm")
End Sub

open "c:\FileName.txt" for append as #1
Print #1,"Willkommen auf die Erde"
Close #1

Private Sub Command1_Click()
On Error GoTo 1
Dim Form1Date As Date
Dim Form2Date As Date
Form1Date = Text1.Text
Form2Date = Text2.Text
Text3.Text = DateDiff("d", Text1.Text, Text2.Text) & " يوم"
Exit Sub
1 MsgBox ("من فضلك أدخل التاريخ بشكل صحيح")
End Sub

Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Option Explicit

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long

Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer

Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_OPEN_TYPE_PROXY = 3
Const INTERNET_FLAG_RELOAD = &H80000000

Public Function Get_File(sURLFileName As String, sSaveFileName As String) As Boolean

   Dim lRet As Long
   On Error GoTo err_Fix

   lRet = InternetOpen("", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
   lRet = URLDownloadToFile(0, sURLFileName, sSaveFileName, 0, 0)
   Get_File = True
   Exit Function
err_Fix:
   Debug.Print Err.LastDllError, lRet
   Err.Clear
   Get_File = False
End Function

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

Private Sub Timer1_Timer()
Label1 = Time & Date
End Sub

Private Sub Command1_Click()
FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat"
End Sub

Private Sub Command1_Click()
Shell "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.syr4u.com/", vbNormalFocus
End Sub

Private Sub Command2_Click()
Dim X As Object
    Set X = CreateObject("InternetExplorer.Application")
        X.Navigate "www.syr4u.com"
    X.Visible = True
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

Private Sub Form_Click()
Dim Ret As Long, A$, x As Integer, y As Integer
x = 10
y = 10
A$ = "c:\Filename.avi"
Ret = mciSendString("stop movie", 0&, 128, 0)
Ret = mciSendString("close movie", 0&, 128, 0)
Ret = mciSendString("open AVIvideo!" & A$ & " alias movie parent " & Form1.hWnd & " style child", 0&, 128, 0)
Ret = mciSendString("put movie window client at " & x & " " & y & " 0 0", 0&, 128, 0)
Ret = mciSendString("play movie", 0&, 128, 0)
End Sub

Private Sub Form_DblClick()
End
End Sub

Private Sub Form_Terminate()
Dim Ret As Long
Ret = mciSendString("close all", 0&, 128, 0)
End Sub

Private Sub Form_Load()
Me.AutoRedraw = True
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
X = Me.CurrentX
Y = Me.CurrentY
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
End Sub

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
DoEvents
frmSlide.Left = frmSlide.Left + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 100)
End Sub

Private Declare Function waveOutSetVolume Lib "Winmm.dll" (ByVal DevID As Integer, ByVal Vol As Long) As Long

Sub SetVol(Volume As Long)
Dim Vol&
Vol = CLng("&H" & Hex(Volume + 65536))
waveOutSetVolume 0, Vol
End Sub

Private Sub Command1_Click()
SetVol Text1.Text
End Sub

Private Sub Form_Load()
Text1.Text = "ضع قيمة عددية تنحصر ما بين 0 و 65536"
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

Declare Function GetSystemDirectory Lib "Kernel32.dll" Alias "GetSystemDirectoryA" (ByVal strBuffer As String, ByVal lngSize As Long) As Long

Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Private Type POINT
X As Long
Y As Long
End Type


Private Sub Command1_Click() 'هذا الايعاز يجعل الماوس لا يخرج عن نطاق الفورم
Dim Client As RECT
Dim Up As POINT
ClientToScreen Me.hwnd, Up
GetClientRect Me.hwnd, Client
OffsetRect Client, Up.X, Up.Y
Up.X = Client.Left
Up.Y = Client.Top
ClipCursor Client
End Sub


Private Sub Command2_Click() 'هذا الايعاز يحرر حركة الماوس
ClipCursor ByVal 0&
End Sub

' في هذا المثال سوف تنحصر حركة الماوس داخل الفورم
' كما يمكنك حصرها داخل أي أداة أخرى
' me.hwnd   باستبدال الكلمة
'أو غيرها  text1.hwnd   , label1.hwnd باسم

App.TaskVisible = False

Private Declare Function SetVolumeLabel Lib "kernel32.dll" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long

Private Sub Command1_Click()
Dim rval As Long
rval = SetVolumeLabel("C:\", Text1.Text)
End Sub

Private Sub Form_Load()
Text1.Text = "Driver 1"
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 Me
End If
End Sub

Printer.Print text1.text

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

Private Sub Timer1_Timer()
   R = Clipboard.GetText
   If Len(R) = 0 Then
   Clipboard.Clear
   End If
End Sub

Private Sub Command1_Click()
RealAudio1.Source = "c:\Demo.ram"
RealAudio1.DoPlay
End Sub

Option Explicit
Private WithEvents btnObj As CommandButton
Private WithEvents txtObj As TextBox


Private Sub btnObj_Click()
On Error Resume Next
Set txtObj = Controls.Add("VB.textbox", "txtObj")
With txtObj
.Visible = True
.RightToLeft = True
.Alignment = 2
.Width = 2000
.Text = "السلام عليكم"
.Top = 2000
.Left = 1000
End With
End Sub

Private Sub Form_Load()
Set btnObj = Controls.Add("VB.CommandButton", "btnObj")
With btnObj
.Visible = True
.Width = 2000
.Caption = "Click"
.Top = 1000
.Left = 1000
End With
End Sub

Option Explicit
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias

"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As

Long) As Long

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub Form_Load()
Dim W
Dim WindowsD As String
WindowsD = Space(144)
W = GetWindowsDirectory(WindowsD, 144)
Text1.Text = WindowsD

Dim S
Dim SystemD As String
SystemD = Space(144)
S = GetSystemDirectory(SystemD, 144)
Text2.Text = SystemD

Dim N
Dim UserN As String
UserN = Space(144)
N = GetUserName(UserN, 144)
Text3.Text = UserN

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

Option Explicit

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C

Private Sub Command1_Click()
keybd_event VK_SNAPSHOT, 1, 1, 1
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = 120 Then
   Email = InputBox("Enter Your Name :", "تحياتي")
   End If
   
   If KeyCode = 121 Then
   Email = InputBox("Enter Your E-mail :", "تحياتي")
   End If
End Sub

Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1

Type typDevMODE
   dmDeviceName       As String * CCDEVICENAME
   dmSpecVersion      As Integer
   dmDriverVersion    As Integer
   dmSize             As Integer
   dmDriverExtra      As Integer
   dmFields           As Long
   dmOrientation      As Integer
   dmPaperSize        As Integer
   dmPaperLength      As Integer
   dmPaperWidth       As Integer
   dmScale            As Integer
   dmCopies           As Integer
   dmDefaultSource    As Integer
   dmPrintQuality     As Integer
   dmColor            As Integer
   dmDuplex           As Integer
   dmYResolution      As Integer
   dmTTOption         As Integer
   dmCollate          As Integer
   dmFormName         As String * CCFORMNAME
   dmUnusedPadding    As Integer
   dmBitsPerPel       As Integer
   dmPelsWidth        As Long
   dmPelsHeight       As Long
   dmDisplayFlags     As Long
   dmDisplayFrequency As Long
End Type

Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
Dim lngDC As Long
Dim intWidth As Integer, intHeight As Integer
Dim intX As Integer, intY As Integer

lngDC = GetDC(0)

intWidth = Screen.Width / Screen.TwipsPerPixelX
intHeight = Screen.Height / Screen.TwipsPerPixelY

form1.Width = intWidth * 15
form1.Height = intHeight * 15

Call BitBlt(hDC, 0, 0, intWidth, intHeight, lngDC, 0, 0, vbSrcCopy)
form1.Visible = vbTrue

Do
intX = (intWidth - 128) * Rnd
intY = (intHeight - 128) * Rnd

Call BitBlt(lngDC, intX, intY + 1, 128, 128, lngDC, intX, intY, vbSrcCopy)

DoEvents
Loop
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set form1 = Nothing
End
End Sub

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

Dim Start,Finsh
FrmShow.Show
Start=Timer
Finsh=Start+3
Do Until Finsh<= Timer
DoEvents
Loop
Unload Frmshow
FrmStart.Show

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As

Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As

Long)
Private Sub Form_Activate()
   DoEvents
   BlockInput True
   Sleep 1000
   BlockInput False
End Sub

Private Sub Command1_Click()
Name "c:\Autoexec.bat" As "D:\Autoexec.bat"
End Sub

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 Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
   lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
   lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
   SetOnTop Form1.hwnd, True
End Sub

Private Sub Form_Load()
Me.Label1.Top = 0
End Sub


Private Sub Timer1_Timer()
a = Me.Height
b = 200
If Me.Label1.Top < a Then 'Me.Height Then
Me.Label1.Top = Me.Label1.Top + b
Exit Sub
End If
For m = 1 To (Int(a / b) + 1)
Me.Label1.Top = Me.Label1.Top - 200
For x = 1 To 1000000
Next
Next
End Sub

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Sub Form_Load()
Timer1.Interval = 100
Timer1.Enabled = True
Timer2.Interval = 100
Timer2.Enabled = True
Form1.Hide
End Sub
Sub Timer1_Timer()
Dim Position As POINTAPI
GetCursorPos Position

Ellipse GetWindowDC(0), Position.x - 7, Position.y - 7, Position.x + 5, Position.y + 5
End Sub

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128
End Type
Private Sub Form_Load()
   Dim OSInfo As OSVERSIONINFO, PId As String
   'Set the graphical mode to persistent
   Me.AutoRedraw = True
   'Set the structure size
   OSInfo.dwOSVersionInfoSize = Len(OSInfo)
   'Get the Windows version
   Ret& = GetVersionEx(OSInfo)
   'Chack for errors
   If Ret& = 0 Then MsgBox "Error Getting Version Information": Exit Sub
   'Print the information to the form
   Select Case OSInfo.dwPlatformId
       Case 0
           PId = "Windows 32s "
       Case 1
           PId = "Windows 95/98"
       Case 2
           PId = "Windows NT "
   End Select
   Print "OS: " + PId
   Print "Win version:" + str$(OSInfo.dwMajorVersion) + "." + LTrim(str(OSInfo.dwMinorVersion))
   Print "Build: " + str(OSInfo.dwBuildNumber)
End Sub

Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hdc As Long, ByVal nCharExtra As Long) As Long

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const COLOR_BTNFACE = 15

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4 ' Character-stream, PLP
Private Const DT_DISPFILE = 6 ' Display-file
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_METAFILE = 5 ' Metafile, VDM
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0 ' Vector plotter
Private Const DT_RASCAMERA = 3 ' Raster camera
Private Const DT_RASDISPLAY = 1 ' Raster display
Private Const DT_RASPRINTER = 2 ' Raster printer
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10

Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

Public Sub TextEffect(obj As Object, ByVal sText As String, ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop As Boolean = False, Optional ByVal lStartSpacing As Long = 128, Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor As OLE_COLOR = vbWindowText)

Dim lhDC As Long
Dim i As Long
Dim x As Long
Dim lLen As Long
Dim hBrush As Long
Static tR As RECT
Dim iDir As Long
Dim bNotFirstTime As Boolean
Dim lTime As Long
Dim lIter As Long
Dim bSlowDown As Boolean
Dim lCOlor As Long
Dim bDoIt As Boolean

lhDC = obj.hdc
iDir = -1
i = lStartSpacing
tR.Left = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lY
OleTranslateColor oColor, 0, lCOlor

hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
lLen = Len(sText)

SetTextColor lhDC, lCOlor
bDoIt = True

Do While bDoIt
lTime = timeGetTime
If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
bSlowDown = True
iDir = 1
lIter = (i + 4)
End If
If (i > 128) Then iDir = -1
If Not (bLoop) And iDir = 1 Then
If (i = lEndSpacing) Then
' Stop
bDoIt = False
Else
lIter = lIter - 1
If (lIter <= 0) Then
i = i + iDir
lIter = (i + 4)
End If
End If
Else
i = i + iDir
End If

FillRect lhDC, tR, hBrush
x = 32 - (i * lLen)
SetTextCharacterExtra lhDC, i
DrawText lhDC, sText, lLen, tR, DT_CALCRECT
tR.Right = tR.Right + 4
If (tR.Right > obj.ScaleWidth \ Screen.TwipsPerPixelX) Then tR.Right = obj.ScaleWidth \ Screen.TwipsPerPixelX
DrawText lhDC, sText, lLen, tR, DT_LEFT
obj.Refresh

Do
DoEvents
If obj.Visible = False Then Exit Sub
Loop While (timeGetTime - lTime) < 20

Loop
DeleteObject hBrush

End Sub

Private Sub Command1_Click()
Me.ScaleMode = vbTwips
Me.AutoRedraw = True
Call TextEffect(Me, "H  e  l  l  o!", 10, 10, False, 75)
End Sub

Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
   peRed As Byte
   peGreen As Byte
   peBlue As Byte
   peFlags As Byte
End Type
Private Type LOGPALETTE
   palVersion As Integer
   palNumEntries As Integer
   palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type
Private Type PicBmp
   Size As Long
   Type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
   Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

   'Fill GUID info
   With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
   End With

   'Fill picture info
   With Pic
       .Size = Len(Pic) ' Length of structure
       .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
       .hBmp = hBmp ' Handle to bitmap
       .hPal = hPal ' Handle to palette (may be null)
   End With

   'Create the picture
   R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

   'Return the new picture
   Set CreateBitmapPicture = IPic
End Function
Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
   Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
   Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
   Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

   'Create a compatible device context
   hDCMemory = CreateCompatibleDC(hDCSrc)
   'Create a compatible bitmap
   hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
   'Select the compatible bitmap into our compatible device context
   hBmpPrev = SelectObject(hDCMemory, hBmp)

   'Raster capabilities?
   RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
   'Does our picture use a palette?
   HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
   'What's the size of that palette?
   PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

   If HasPaletteScrn And (PaletteSizeScrn = 256) Then
       'Set the palette version
       LogPal.palVersion = &H300
       'Number of palette entries
       LogPal.palNumEntries = 256
       'Retrieve the system palette entries
       R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
       'Create the palette
       hPal = CreatePalette(LogPal)
       'Select the palette
       hPalPrev = SelectPalette(hDCMemory, hPal, 0)
       'Realize the palette
       R = RealizePalette(hDCMemory)
   End If

   'Copy the source image to our compatible device context
   R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

   'Restore the old bitmap
   hBmp = SelectObject(hDCMemory, hBmpPrev)

   If HasPaletteScrn And (PaletteSizeScrn = 256) Then
       'Select the palette
       hPal = SelectPalette(hDCMemory, hPalPrev, 0)
   End If

   'Delete our memory DC
   R = DeleteDC(hDCMemory)

   Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Private Sub Form_Load()
   'Create a picture object from the screen
   Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
End Sub

' 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 = Left(GetMyMachineName, sLen)
   End If
End Function
Private Sub Form_Load()
   InitiateShutdownMachine GetMyMachineName, True, True, True, 60, "You initiated a system shutdown..."
End Sub

Dim x,y As Integer
x = Screen.Width / 15
y = Screen.Height / 15
If x = 640 And y = 480 Then MsgBox ("640 * 480")
If x = 800 And y = 600 Then MsgBox ("800 * 600")
If x = 1024 And y = 768 Then MsgBox ("1024 * 768")

Public Const DT_CENTER = &H1
Public Const DT_WORDBREAK = &H10
Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Global Cnt As Long, sSave As String, sOld As String, Ret As String
Dim Tel As Long
Function GetPressedKey() As String
   For Cnt = 32 To 128
       'Get the keystate of a specified key
       If GetAsyncKeyState(Cnt) <> 0 Then
           GetPressedKey = Chr$(Cnt)
           Exit For
       End If
   Next Cnt
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
   Ret = GetPressedKey
   If Ret <> sOld Then
       sOld = Ret
       sSave = sSave + sOld
   End If
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

Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Private Sub Command1_Click()
X = ShowCursor(False)
End Sub

Private Sub Command2_Click()
X = ShowCursor(True)
End Sub

Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21               ' default

for FTP servers
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_FLAG_PASSIVE = &H8000000            ' used

for FTP connections
Const INTERNET_OPEN_TYPE_PRECONFIG = 0                    '

use registry configuration
Const INTERNET_OPEN_TYPE_DIRECT = 1                        '

direct to net
Const INTERNET_OPEN_TYPE_PROXY = 3                         '

via named proxy
Const

INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY =

4   ' prevent using java/script/INS
Const MAX_PATH = 260
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Const PassiveConnection As Boolean = True
Private Sub Form_Load()
    Dim hConnection As Long, hOpen As Long, sOrgPath  As String
   'open an internet connection
   hOpen = InternetOpen("API-Guide sample program",

INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
   'connect to the FTP server
   hConnection = InternetConnect(hOpen, "your ftp server",

INTERNET_DEFAULT_FTP_PORT, "your login", "your password", INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
   'create a buffer to store the original directory
   sOrgPath = String(MAX_PATH, 0)
   'get the directory
   FtpGetCurrentDirectory hConnection, sOrgPath, Len(sOrgPath)
   'create a new directory 'testing'
   FtpCreateDirectory hConnection, "testing"
   'set the current directory to 'root/testing'
   FtpSetCurrentDirectory hConnection, "testing"
   'upload the file 'test.htm'
   FtpPutFile hConnection, "C:\test.htm", "test.htm",

FTP_TRANSFER_TYPE_UNKNOWN, 0
   'rename 'test.htm' to 'apiguide.htm'
   FtpRenameFile hConnection, "test.htm", "apiguide.htm"
   'enumerate the file list from the current directory ('root/testing')
   EnumFiles hConnection
   'retrieve the file from the FTP server
   FtpGetFile hConnection, "apiguide.htm", "c:\apiguide.htm", False,

0, FTP_TRANSFER_TYPE_UNKNOWN, 0
   'delete the file from the FTP server
   FtpDeleteFile hConnection, "apiguide.htm"
   'set the current directory back to the root
   FtpSetCurrentDirectory hConnection, sOrgPath
   'remove the direcrtory 'testing'
   FtpRemoveDirectory hConnection, "testing"
   'close the FTP connection
   InternetCloseHandle hConnection
   'close the internet connection
   InternetCloseHandle hOpen
End Sub
Public Sub EnumFiles(hConnection As Long)
   Dim pData As WIN32_FIND_DATA, hFind As Long, lRet As Long
   'set the graphics mode to persistent
   Me.AutoRedraw = True
   'create a buffer
   pData.cFileName = String(MAX_PATH, 0)
   'find the first file
   hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
   'if there's no file, then exit sub
   If hFind = 0 Then Exit Sub
   'show the filename
   Me.Print Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
   Do
       'create a buffer
       pData.cFileName = String(MAX_PATH, 0)
       'find the next file
       lRet = InternetFindNextFile(hFind, pData)
       'if there's no next file, exit do
       If lRet = 0 Then Exit Do
       'show the filename
       Me.Print Left(pData.cFileName, InStr(1, pData.cFileName,

String(1, 0), vbBinaryCompare) - 1)
   Loop
   'close the search handle
   InternetCloseHandle hFind
End Sub
Sub ShowError()
   Dim lErr As Long, sErr As String, lenBuf As Long
   'get the required buffer size
   InternetGetLastResponseInfo lErr, sErr, lenBuf
   'create a buffer
   sErr = String(lenBuf, 0)
   'retrieve the last respons info
   InternetGetLastResponseInfo lErr, sErr, lenBuf
   'show the last response info
   MsgBox "Error " + CStr(lErr) + ": " + sErr, vbOKOnly + vbCritical
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

Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
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

Private Sub Command1_Click()
'الوضع الطبيعي النسخ
Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, 0, 0, Picture1.Width, Picture1.Height, vbSrcCopy
End Sub

Private Sub Command2_Click()
'الوضع الافقي
Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, Picture1.Width, 0, -Picture1.Width, Picture1.Height, vbSrcCopy
End Sub

Private Sub Command3_Click()
'الوضع العمودي
Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, 0, Picture1.Height, Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub

Private Sub Command4_Click()
'لقلب الصورة
Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, Picture1.Width, Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub

Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4
Private Const PM_REMOVE = &H1
Private Const WM_HOTKEY = &H312
Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type Msg
   hWnd As Long
   Message As Long
   wParam As Long
   lParam As Long
   time As Long
   pt As POINTAPI
End Type
Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private bCancel As Boolean
Private Sub ProcessMessages()
   Dim Message As Msg
   'loop until bCancel is set to True
   Do While Not bCancel
       'wait for a message
       WaitMessage
       'check if it's a HOTKEY-message
       If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
           'minimize the form
           WindowState = vbMinimized
       End If
       'let the operating system process other events
       DoEvents
   Loop
End Sub
Private Sub Form_Load()
   
   Dim ret As Long
   bCancel = False
   'register the Ctrl-F hotkey
   ret = RegisterHotKey(Me.hWnd, &HBFFF&, MOD_CONTROL, vbKeyF)
   'show some information
   Me.AutoRedraw = True
   Me.Print "Press CTRL-F to minimize this form"
   'show the form and
   Show
   'process the Hotkey messages
   ProcessMessages
End Sub
Private Sub Form_Unload(Cancel As Integer)
   bCancel = True
   'unregister hotkey
   Call UnregisterHotKey(Me.hWnd, &HBFFF&)
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 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

h = WindowFromPoint(x, y)

Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub

Private Sub COMMAND1_CLICK()
SetAttr "C:\data.txt", vbHidden
SetAttr "C:\data.txt", vbReadOnly
SetAttr "C:\data.txt", vbArchive
End Sub

Private Sub Command1_Click()
MsgBox ("عدد الحروف = " + Str(Len(Text1.Text)))
End Sub

Option Explicit

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Picture1.Move X - 200, Y - 200
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

Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1

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

Public Function reversestring(revstr As String) As String
Dim doreverse As Long
reversestring = ""
For doreverse = Len(revstr) To 1 Step -1
reversestring = reversestring & Mid$(revstr, doreverse, 1)
Next
End Function

Private Sub Command1_Click()
Dim strResult As String
strResult = reversestring(Text1.Text)
Text2.Text = strResult
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 Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Sub Command1_Click()
Me.AutoRedraw = True
       Select Case GetDriveType(Text1.Text & ":\")
       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 GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName 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
  Text1.Text = drv
   Const RootPathName = "c:\"
   Call GetDiskFreeSpaceEx(RootPathName, 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_QueryUnload(Cancel As Integer, UnloadMode As
Integer)
Cancel = True
End Sub

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Dim P As POINTAPI
Private Sub Form_Load()

   Command1.Caption = "Screen Middle"
   Command2.Caption = "Form Middle"
   'API uses pixels
   Me.ScaleMode = vbPixels
End Sub
Private Sub Command1_Click()
   'Get information about the screen's width
   P.x = GetDeviceCaps(Form1.hdc, 8) / 2
   'Get information about the screen's height
   P.y = GetDeviceCaps(Form1.hdc, 10) / 2
   'Set the mouse cursor to the middle of the screen
   ret& = SetCursorPos(P.x, P.y)
End Sub
Private Sub Command2_Click()
   P.x = 0
   P.y = 0
   'Get information about the form's left and top
   ret& = ClientToScreen&(Form1.hwnd, P)
   P.x = P.x + Me.ScaleWidth / 2
   P.y = P.y + Me.ScaleHeight / 2
   'Set the cursor to the middle of the form
   ret& = SetCursorPos&(P.x, P.y)
End Sub

Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020

'تغميق الصورة
Private Sub Command1_Click()
   Dim lDC As Long
   Dim lBMP As Long
   Dim W As Integer
   Dim H As Integer
   Dim lColor As Long
   
   Screen.MousePointer = vbHourglass
   
   W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
   H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
   lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
   lDC = CreateCompatibleDC(Picture1.hdc)
   Call SelectObject(lDC, lBMP)
   BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
   Picture1 = LoadPicture("")
   
   For lColor = 255 To 0 Step -3
       Picture1.BackColor = RGB(lColor, lColor, lColor)
       BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
       Sleep 15
   Next
   Call DeleteDC(lDC)
   Call DeleteObject(lBMP)
   Screen.MousePointer = vbDefault
   
End Sub

'تفتيح الصورة
Private Sub Command2_Click()
   Dim lDC As Long
   Dim lBMP As Long
   Dim W As Integer
   Dim H As Integer
   Dim lColor As Long
   
   Screen.MousePointer = vbHourglass
   
   W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
   H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
   lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
   lDC = CreateCompatibleDC(Picture1.hdc)
   Call SelectObject(lDC, lBMP)
   BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
   Picture1 = LoadPicture("")
   
   For lColor = 0 To 255 Step +3
       Picture1.BackColor = RGB(lColor, lColor, lColor)
       BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
       Sleep 15
   Next
   Call DeleteDC(lDC)
   Call DeleteObject(lBMP)
   Screen.MousePointer = vbDefault
   
End Sub

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

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (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_COMPUTERNAME_LENGTH + 1
   strString = String(dwLen, "X")
   'Get the computer name
   GetComputerName strString, dwLen
   'get only the actual data
   strString = Left(strString, dwLen)
   'Show the computer name
   MsgBox strString
End Sub

Private Sub Command1_Click()
Dim PhoneNumber As String
On Error GoTo WrongPort
MSComm1.CommPort = 3 'قم بتغيير البورت من 1 إلى 8 حتى تصل إلى البورت الصحيح
MSComm1.Settings = "300,n,8,1"
PhoneNumber = "164883"
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

Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next

End Sub
Private Sub Form_Load()
Explode Me
End Sub

Private strText As String
Private Sub Form_Load()
Timer1.Interval = 75
strText = "Guten Tag! Wie ght's Ihnen? Ich hoffe Ihnen alles Gutes!"
strText = Space(50) & strText
End Sub
Private Sub Timer1_Timer()
strText = Mid(strText, 2) & Left(strText, 1)
Text1.Text = strText
Me.Caption = strText
End Sub

Private Sub Timer1_Timer()
Static Col1, Col2, Col3 As Integer
Static c1, C2, C3 As Integer
If (Col1 = 0 Or Col1 = 250) And (Col2 = 0 Or Col2 = 250) And (Col3 = 0 Or Col3 = 250) Then
c1 = Int(Rnd * 3)
C2 = Int(Rnd * 3)
C3 = Int(Rnd * 3)
End If
If c1 = 1 And Col1 <> 0 Then Col1 = Col1 - 10
If C2 = 1 And Col2 <> 0 Then Col2 = Col2 - 10
If C3 = 1 And Col3 <> 0 Then Col3 = Col3 - 10
If c1 = 2 And Col1 <> 250 Then Col1 = Col1 + 10
If C2 = 2 And Col2 <> 250 Then Col2 = Col2 + 10
If C3 = 2 And Col3 <> 250 Then Col3 = Col3 + 10
Label1.ForeColor = RGB(Col1, Col2, Col3)
End Sub
Private Sub Form_Load()
Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
Static Col1, Col2, Col3 As Integer
Static c1, C2, C3 As Integer
If (Col1 = 0 Or Col1 = 250) And (Col2 = 0 Or Col2 = 250) _
And (Col3 = 0 Or Col3 = 250) Then
c1 = Int(Rnd * 3)
C2 = Int(Rnd * 3)
C3 = Int(Rnd * 3)
End If
If c1 = 1 And Col1 <> 0 Then Col1 = Col1 - 10
If C2 = 1 And Col2 <> 0 Then Col2 = Col2 - 10
If C3 = 1 And Col3 <> 0 Then Col3 = Col3 - 10
If c1 = 2 And Col1 <> 250 Then Col1 = Col1 + 10
If C2 = 2 And Col2 <> 250 Then Col2 = Col2 + 10
If C3 = 2 And Col3 <> 250 Then Col3 = Col3 + 10
Label1.BackColor = RGB(Col1, Col2, Col3)
End Sub

Private Sub Timer1_Timer()
Static COL
COL = COL + 10
If COL > 510 Then COL = 0
Label1.BackColor = RGB(Abs(COL - 255), 0, 0)
Label2.BackColor = RGB(0, Abs(COL - 255), 0)
Label3.BackColor = RGB(0, 0, Abs(COL - 255))
Label4.BackColor = RGB(Abs(COL - 0), 180, 180)
Label5.BackColor = RGB(Abs(COL - 200), 30, 180)
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

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_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

Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long

Private Sub Command1_Click()
SHEmptyRecycleBin Me.hwnd, vbNullString, 0
SHUpdateRecycleBinIcon
End Sub

Dim Genie As IAgentCtlCharacter
Private Sub Command1_Click()
Genie.Show
End Sub
Private Sub Command2_Click()
Genie.Hide
End Sub

Private Sub Command3_Click()
Genie.Play "Congratulate"
End Sub

Private Sub Command4_Click()
Genie.Play "Pleased"
End Sub

Private Sub Command5_Click()
Genie.Play "lookup"
End Sub

Private Sub Command6_Click()
Genie.Play "Think"
End Sub

Private Sub Form_Load()
Dim Filename
Filename = "ضع مسار المساعد هنا وغالباً ما  يكون في المسار التالي  \windows\msagent\char"
' على سبيل المثال
' c:\windows\msagent\char\genie.acs
Agent1.Characters.Load CharacterID:="Genie", LoadKey:=Filename
Set Genie = Agent1.Characters("Genie")
End Sub

Private Sub Form_Load()
Form1.Height = 7020
Form1.WindowState = 0
Timer1.Interval = 45

End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Form1.Height = Form1.Height - 250
Timer2.Interval = 1500

End Sub

Private Sub Timer2_Timer()
End
End Sub

Private Sub Command1_Click()
Clipboard.Clear
Clipboard.SetText text1
End Sub

Private Sub Command2_Click()
Clipboard.Clear
Clipboard.SetText text1
text1 =""
End Sub

Private Sub Command3_Click()
text1 = Clipboard.GetText
End Sub

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()
x = Text1.Text
y = UCase(Left(x, Len(x)))
Text1.Text = y
End Sub
Private Sub Command2_Click()
x = Text1.Text
y = LCase(Left(x, Len(x)))
Text1.Text = y
End Sub

Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Public Const MF_BYPOSITION = &H400&

Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
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 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 Form_Load()
  Const WS_MAXIMIZEBOX = &H10000
  Const GWL_STYLE = (-16)
  Const SWP_FRAMECHANGED = &H20
  Const SWP_NOMOVE = &H2
  Const SWP_NOSIZE = &H1

  Dim nStyle As Long
  nStyle = GetWindowLong(Me.hWnd, GWL_STYLE)
  Call SetWindowLong(Me.hWnd, GWL_STYLE, nStyle And Not WS_MAXIMIZEBOX)
  SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
End Sub