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