اكواد فيجوال

----------

Private Sub Form_Load()

FrmCenter Me 'Center The Form

LabLoaded.Caption = List1.ListCount 'Set LabLoaded Caption To 0

End Sub

'Clear List

Private Sub cmdClear_Click()

ClsLst List1 'The Clear List Function

LabLoaded.Caption = List1.ListCount 'Show The How Many Lines List1 Consists Of...

End Sub

'Load List

Private Sub cmdLoad_Click()

Dim FN As String 'FN = FileName

FN = App.Path & "\List.txt" 'File To Be Loaded

LoadList FN, List1 'Load List Function

LabLoaded.Caption = List1.ListCount 'Show The How Many Lines List1 Consists Of...

End Sub

'LoadList Function

Private Function LoadList(ByRef SF As String, ByRef lBox As ListBox) 'SF = SourceFile

On Error GoTo 0

Dim tmp As String, F As Integer

ClsLst lBox 'Clear ListBox Before Loading A List

F = FreeFile

Open SF For Input As #F

Do While Not EOF(F) 'While Not (End Of File)

Line Input #F, tmp 'Input Lines Of text

If tmp <> vbNullString Then lBox.AddItem (tmp) 'If Text File(.txt) Has Text in It, Add it To The ListBox

Loop 'Loop Until Text File if EOF

Close #F

Exit Function

0:

'Error 51 - Internal Error

'Error 52 - Bad file name or number

'Error 51 - File not found

'Error 31037 - Error loading from file

If Err.Number = 51 Or Err.Number = 52 Or Err.Number = 53 Or Err.Number = 31037 Then

Exit Function

End If

End Function

'Clear ListBox Function

'This Will Loop Until The Listbox is Completley Cleared

Public Function ClsLst(lst As ListBox)

Dim i%

For i = 0 To lst.ListCount

Do While lst.ListCount <> 0

lst.Clear

DoEvents

Loop

Next i

End Function

'Centers Form A Little Bit Lower Than The Actual Center

Public Function FrmCenter(Frm As Form)

Dim SW%, SH%

SW = Screen.Width / 2 - Frm.Width / 2: SH = (Screen.Height * 1) / 2 - Frm.Height / 2

Frm.Left = SW

Frm.Top = SH

End Function

اداة progress bar تعمل على Timer

Private Sub tmrPb_Timer()

pbSplash.Value = pbSplash.Value + 1

If pbSplash.Value = 100 Then

frmMain.Show 1

End If

End Sub

استخدام Helper فى المساعدة

Private Sub Command3_GotFocus()

Merlin "Select Category And Press Enter"

End Sub

&System Info... Code

========

Const HKEY_LOCAL_MACHINE = &H80000002

Const ERROR_SUCCESS = 0

Const REG_SZ = 1 ' Unicode nul terminated string

Const REG_DWORD = 4 ' 32-bit number

Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"

Const gREGVALSYSINFOLOC = "MSINFO"

Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"

Const gREGVALSYSINFO = "PATH"

Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long

Private Sub cmdSysInfo_Click()

Call StartSysInfo

End Sub

copy and past code

===================

' In Class Name it cTextboxedit Option Explicit

Private Declare Function SendMessageLong Lib "USER32" Alias _

"SendMessageA" (ByVal hWnd As Long , ByVal wMsg As Long , _

ByVal wParam As Long , ByVal lParam As Long) As Long

Private Declare Function SendMessageString Lib "USER32" Alias _

"SendMessageA" (ByVal hWnd As Long , ByVal wMsg As Long , _

ByVal wParam As Long , ByVal lParam As String) As Long

Private Const WM_COMMAND = &H111

Private Const WM_CUT = &H300

Private Const WM_COPY = &H301

Private Const WM_PASTE = &H302

Private Const EM_UNDO = &HC7

Private Const EM_CANUNDO = &HC6

Private Const EM_REPLACESEL = &HC2

Private Declare Function IsClipboardFormatAvailable Lib "USER32" _

(ByVal wFormat As Long) As Long

Private Const CF_TEXT = 1

Private Const CF_UNICODETEXT = 13

Private Const CF_OEMTEXT = 7

Private My_txt As TextBox

Public Property Let TextBox(ByRef New_txt As TextBox)

Set My_txt = New_txt

End Property

Public Sub Cut()

SendMessageLong My_txt.hWnd , WM_CUT , 0 , 0

End Sub

Public Sub Copy()

SendMessageLong My_txt.hWnd , WM_COPY , 0 , 0

End Sub

Public Sub Paste()

SendMessageLong My_txt.hWnd , WM_PASTE , 0 , 0

End Sub

Public Sub Undo()

If (SendMessageLong(My_txt.hWnd , EM_CANUNDO , 0 , 0) < > 0) Then

SendMessageLong My_txt.hWnd , EM_UNDO , 0 , 0

End If

End Sub

Public Property Get CanCut() As Boolean

CanCut = (Not (My_txt.Locked) And My_txt.SelLength > 0)

End Property

Public Property Get CanCopy() As Boolean

CanCopy = (My_txt.SelLength > 0)

End Property

Public Property Get CanPaste() As Boolean

If IsClipboardFormatAvailable(CF_TEXT) Then

CanPaste = True

ElseIf IsClipboardFormatAvailable(CF_UNICODETEXT) Then

CanPaste = True

ElseIf IsClipboardFormatAvailable(CF_OEMTEXT) Then

CanPaste = True

End If

End Property

Public Property Get CanUndo() As Boolean

CanUndo = (SendMessageLong(My_txt.hWnd , EM_CANUNDO , 0 , 0) < > 0)

End Property

Public Sub ReplaceSelection(ByRef sText As String , _

Optional ByVal bAllowUndo = True)

Dim lR As Long

If (My_txt.SelLength > 0) Then

lR = Abs(bAllowUndo)

SendMessageString My_txt.hWnd , EM_REPLACESEL , lR , sText

End If

End Sub

Public Sub Delete(Optional ByVal bAllowUndo = True)

Dim lR As Long

SendMessageString My_txt.hWnd , EM_REPLACESEL , lR , vbNullChar

End Sub

' Placet textbox in form (Text1) Dim New_text As ctextboxedit

Private Sub Form_Load()

Set New_text = New ctextboxedit

New_text.TextBox = Text1

End Sub

' Example of the undo use

Private Sub Command1_Click()

If New_text.CanUndo Then

New_text.Undo

End If

End Sub

Task Manager

dim k as long

k = shell("c:\windows\system32\taskmgr.exe",vbhide)

'to show taskmgr

k = shell("c:\windows\system32\taskmgr.exe",vbmaximizedfocus)

Tray icon

Public Const WM_RBUTTONDOWN = &H204

Public Const WM_RBUTTONUP = &H205

Public Const WM_ACTIVATEAPP = &H1C

Public Const NIF_ICON = &H2

Public Const NIF_form1SSAGE = &H1

Public Const NIF_TIP = &H4

Public Const NIM_ADD = &H0

Public Const NIM_DELETE = &H2

Public Const MAX_TOOLTIP As Integer = 64

Public Const GWL_WNDPROC = (-4)

Option Explicit

Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwform1ssage As Long, lpData As NOTIFYICONDATA) As Long

Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _

ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Type NOTIFYICONDATA

cbSize As Long

hWnd As Long

uID As Long

uFlags As Long

uCallbackform1ssage As Long

hIcon As Long

szTip As String * MAX_TOOLTIP

End Type

Public nfIconData As NOTIFYICONDATA

Public FHandle As Long ' Storage for form handle

Public WndProc As Long ' Address of our handler

Public Hooking As Boolean ' Hooking indicator

Public Sub Command1_Click()

On Error Resume Next

Hook CMAE_INVISBLE_FORM.hWnd ' Set up our handler

AddIconToTray CMAE_INVISBLE_FORM.hWnd, CMAE_INVISBLE_FORM.Icon,

CMAE_INVISBLE_FORM.Icon.Handle, "I am printing Quotes, Dont terminate me"

End Sub

' Handler for mouse events occuring in system tray.

Public Sub SysTrayMouseEventHandler()

On Error Resume Next

SetForegroundWindow CMAE_INVISBLE_FORM.hWnd

End Sub

Public Sub command2_Click()

On Error Resume Next

Unhook ' Return event control to windows

RemoveIconFromTray

End Sub

' Example - AddIconToTray CMAE_INVISBLE_FORM.Hwnd, CMAE_INVISBLE_FORM.Icon, CMAE_INVISBLE_FORM.Icon.Handle, "This is a test tip"

Public Sub AddIconToTray(form1Hwnd As Long, form1Icon As Long, form1IconHandle As Long, Tip As String)

On Error Resume Next

With nfIconData

.hWnd = form1Hwnd

.uID = form1Icon

.uFlags = NIF_ICON Or NIF_form1SSAGE Or NIF_TIP

.uCallbackform1ssage = WM_RBUTTONUP

.hIcon = form1IconHandle

.szTip = Tip & Chr$(0)

.cbSize = Len(nfIconData)

End With

Shell_NotifyIcon NIM_ADD, nfIconData

End Sub

' Remove your application from the system tray.

' Call when you quit your application.

Public Sub RemoveIconFromTray()

On Error Resume Next

Shell_NotifyIcon NIM_DELETE, nfIconData

End Sub

' Call this routine to ensure my app gets notified of all events

' Example - Hook form1.hWnd

Public Sub Hook(Lwnd As Long)

On Error Resume Next

If Hooking = False Then

FHandle = Lwnd

WndProc = SetWindowLong(Lwnd, GWL_WNDPROC, 0)

Hooking = True

End If

End Sub

' Call this routine to transfer event notification back to standard handler

' Example - Unhook

Public Sub Unhook()

On Error Resume Next

If Hooking = True Then

SetWindowLong FHandle, GWL_WNDPROC, WndProc

Hooking = False

End If

End Sub

' Detect a right click event on our system tray icon - pass control to a handler routine

' in the main form (change as required)

Public Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

On Error Resume Next

' Ensure that its our app thats affected and that its the right event

If Hooking = True Then

If uMsg = WM_RBUTTONUP And lParam = WM_RBUTTONDOWN Then

Call SysTrayMouseEventHandler ' Pass the event back to the form handler

WindowProc = True ' Let windows know we handled it

Exit Function

End If

WindowProc = CallWindowProc(WndProc, hw, uMsg, wParam, lParam) ' Pass it along

End If

End Function

Public Sub CreateShortcut(ByVal datedir As String)

On Error Resume Next

Dim wscript

Dim wshshell

Dim strdesktop As String

Dim oshelllink

Set wshshell = CreateObject("WScript.Shell")

strdesktop = wshshell.SpecialFolders("Desktop")

Set oshelllink = wshshell.CreateShortcut(strdesktop & "\Printing Quotes.lnk")

oshelllink.TargetPath = datedir

oshelllink.WindowStyle = 1

' oShellLink.Hotkey = "CTRL+SHIFT+F" '//REMOVED ON 23rd JUL 06

oshelllink.IconLocation = "notepad.exe, 0"

oshelllink.Description = "Printed Quotes"

oshelllink.WorkingDirectory = strdesktop

oshelllink.Save

End Sub

--------------------------------------------------------

' Put above declarations part in a seperate Module

'------------------------------------------------------------------------

'-----------

private sub form_load()

'Just call command1_click to display systray icon

call command1_click

end sub

'-------------

private sub form_unload()

'Just call command2_click to remove systray icon

call command2_click

end sub

'---------------

معرفة العناوين تحت مؤشر الماوس

Private Declare Function GetForegroundWindow Lib user32 () As Long

Private Declare Function GetWindowTextLength Lib user32 _

Alias GetWindowTextLengthA (ByVal hwnd As Long) As Long

Private Declare Function GetWindowText Lib user32 _

Alias GetWindowTextA (ByVal hwnd As Long ByVal lpString As String _

ByVal cch As Long) As Long

Private Declare Function SetWindowText Lib user32 _

Alias SetWindowTextA (ByVal hwnd As Long _

ByVal lpString As String) As Long

Private Declare Function FindWindow& Lib user32 _

Alias FindWindowA (ByVal lpClassName As String _

ByVal lpWindowName As String)

Private Declare Function GetWindow& Lib user32 _

(ByVal hwnd As Long ByVal wCmd As Long)

Private Declare Function Sendmessagebynum& Lib user32 _

Alias SendMessageA (ByVal hwnd As Long ByVal wMsg As Long _

ByVal wParam As Long ByVal lParam As Long)

Private Declare Function SendMessageByString& Lib user32 _

Alias SendMessageA (ByVal hwnd As Long ByVal wMsg As Long _

ByVal wParam As Long ByVal lParam As String)

Private Declare Function GetCursorPos& Lib user32 _

(lpPoint As POINTAPI)

Private Declare Function WindowFromPoint& Lib user32 _

(ByVal x As Long ByVal y As Long)

Private Declare Function ChildWindowFromPoint& Lib user32 _

(ByVal hwnd As Long ByVal x As Long ByVal y 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)

Private Declare Function UpdateWindow& Lib user32 (ByVal hwnd As Long)

Const SWP_NOACTIVATE &H10

Const SWP_NOREDRAW &H8

Const SWP_NOSIZE &H1

Const SWP_NOZORDER &H4

Const SWP_NOMOVE &H2

Const HWND_TOPMOST -1

Const HWND_BOTTOM 1

Const SWP_HIDEWINDOW &H80

Const WM_SETTEXT &HC

Const WM_GETTEXT &HD

Const WM_CHAR &H102

Const WM_CLEAR &H303

Const GW_CHILD 5

Const GW_HWNDNEXT 2

Const EM_SETPASSWORDCHAR &HCC

Const EM_GETPASSWORDCHAR &HD2

Const EN_CHANGE &H300

Dim Abort LastWindow& LastCaption$

Private Type POINTAPI

x As Long

y As Long

End Type

Function GetCaption(hwnd) As String

Dim capt As String TChars As String

capt$ Space$(255)

TChars$ GetWindowText(hwnd capt$ 255)

GetCaption Left$(capt$ TChars$)

End Function

Function GetText(hwnd) As String

Dim GetTrim As Long TrimSpace As String GetString As String

GetTrim Sendmessagebynum(hwnd 14 0& 0&)

TrimSpace$ Space$(GetTrim)

GetString SendMessageByString(hwnd 13 GetTrim 1 TrimSpace$)

GetText TrimSpace$

End Function

Private Sub Form_Load()

Call SetWindowPos(Form1.hwnd HWND_TOPMOST 0& 0& 0& _

0& SWP_NOMOVE Or SWP_NOSIZE)

End Sub

Private Sub Form_Unload(Cancel As Integer)

Abort 1

End Sub

Private Sub Timer1_Timer()

Dim mypoint As POINTAPI A As Long B As Long

Call GetCursorPos(mypoint)

A& WindowFromPoint(mypoint.x mypoint.y)

B& ChildWindowFromPoint(A& mypoint.x mypoint.y)

If A& Form1.hwnd Then Exit Sub

Label1.Caption GetCaption(A&)

Label2.Caption GetText(A&)

End Sub

مسح كل محتويات

Public Sub ClearAllText(frm As Form, ctl As Control)

For Each ctl In frm

If TypeOf ctl Is TextBox Then

ctl.Text = ""

End If

Next ctl

Move Form form any point

Private Declare Function ReleaseCapture Lib "user32" () As Long

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

'ÇáÞíã ÇáãÓÇÚÏÉ

Const WM_NCLBUTTONDOWN = &HA1

Const HTCAPTION = 2

'ÈÏÁ ÇáÊÝíÐ

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'ÚäÏ ÊÍÑíß ÇáãÇæÓ ÝæÞ ÇáÝæÑã

ReleaseCapture 'äÝÐ ÊÇÈÚ ÇáÇí Èí Âí

SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0 'ÅÚØÇÁ ÇáÃæÇãÑ ááÝæÑã ÈÇáÅäÊÞÇá

End Sub

Dreaw Your Form تشكيل الفورم على دائرة مستطيل

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Private Sub form_paint()

Dim HnHn(3) As Long

HnHn(0) = CreateRoundRectRgn(48, 48, 300, 200, 20, 20)

HnHn(1) = CreateEllipticRgn(16, 4, 90, 80)

HnHn(2) = CreateRoundRectRgn(48, 200, 300, 220, 20, 20)

HnHn(3) = CreateRectRgn(245, 4, 300, 29)

CombineRgn HnHn(0), HnHn(0), HnHn(1), 2

CombineRgn HnHn(2), HnHn(2), HnHn(0), 2

CombineRgn HnHn(3), HnHn(3), HnHn(2), 2

SetWindowRgn Me.hWnd, HnHn(3), True

End Sub

كود OPEN MUNE

==========

With CommonDialog1

'هذا المتحول خاص بفلترة الملفات الظاهرة

.Filter = "Flash File(*.swf)|*.swf| All File(*.*)|*.*|"

'هذا المتحول يقوم باظهار الملفات حتى المخفية

.Flags = cdlOFNHideReadOnly Or cdlOFNFileMustExist Or cdlOFNPathMustExist

'يتم تسمية عنوان مربع الفتح

.DialogTitle = "Open Flash File"

'يتم تصفير الاسم الابتدائى

.FileName = ""

'يتم فتح المنوذج او مربع الحوار

.ShowOpen

'فى حالة لم يتم فتح المجلد يتم الخروج من الاجراء

If .FileName = "" Then Exit Sub

' يتم اسناد اسم الملف الى المتغير الخاص باسم الملف

ShockwaveFlash1.Movie = .FileName

End With

Mnu_File_Close.Enabled = True

Mnu_File_Print.Enabled = True

Mnu_View_100.Enabled = True

Mnu_View_All.Enabled = True

Mnu_View_ZoomIn.Enabled = True

Mnu_View_ZoomOut.Enabled = True

Mnu_Control_Play.Enabled = True

Mnu_Control_Rewind.Enabled = True

Mnu_Control_Forward.Enabled = True

Mnu_Control_Back.Enabled = True

Mnu_Control_Loop.Enabled = True

Mnu_Control_Play.Checked = True

Mnu_Control_Rewind.Checked = False

End Sub

'الكود كامل

Option Explicit

Private Sub Form_Resize()

With ShockwaveFlash1

.Top = 0

.Left = 0

.Width = Me.ScaleWidth

.Height = Me.ScaleHeight

End With

End Sub

Private Sub Mnu_Control_Back_Click()

Mnu_Control_Play.Checked = False

Mnu_Control_Rewind.Checked = False

ShockwaveFlash1.Back

End Sub

Private Sub Mnu_Control_Forward_Click()

Mnu_Control_Play.Checked = False

Mnu_Control_Rewind.Checked = False

ShockwaveFlash1.Forward

End Sub

Private Sub Mnu_Control_Loop_Click()

ShockwaveFlash1.Loop = True

End Sub

Private Sub Mnu_Control_Play_Click()

If Mnu_Control_Play.Checked = True Then Exit Sub

Mnu_Control_Play.Checked = True

Mnu_Control_Rewind.Checked = False

Mnu_Control_Back.Enabled = True

Mnu_Control_Rewind.Enabled = True

If Mnu_Control_Loop.Checked = True Then

Mnu_Control_Loop.Checked = False

ShockwaveFlash1.Loop = False

Else

Mnu_Control_Loop.Checked = True

ShockwaveFlash1.Loop = True

End If

End Sub

Private Sub Mnu_Control_Rewind_Click()

If Mnu_Control_Rewind.Checked = True Then Exit Sub

Mnu_Control_Play.Checked = False

Mnu_Control_Rewind.Checked = True

Mnu_Control_Back.Enabled = False

Mnu_Control_Rewind.Enabled = False

ShockwaveFlash1.Rewind

End Sub

Private Sub Mnu_File_Close_Click()

ShockwaveFlash1.Stop

ShockwaveFlash1.Movie = ""

Mnu_File_Close.Enabled = False

Mnu_File_Print.Enabled = False

Mnu_View_100.Enabled = False

Mnu_View_All.Enabled = False

Mnu_View_ZoomIn.Enabled = False

Mnu_View_ZoomOut.Enabled = False

Mnu_Control_Play.Enabled = False

Mnu_Control_Rewind.Enabled = False

Mnu_Control_Forward.Enabled = False

Mnu_Control_Back.Enabled = False

Mnu_Control_Loop.Enabled = False

Mnu_Control_Play.Checked = False

Mnu_Control_Rewind.Checked = False

End Sub

Private Sub Mnu_File_Exit_Click()

Unload Me

End Sub

Private Sub Mnu_File_Open_Click()

With CommonDialog1

'åÐÇ ÇáãÊÍæá ÎÇÕ ÈäæÚíÉ ÝáÊÑ ÇáãáÝÇÊ ÇáÙÇåÑÉ

.Filter = "Flash File(*.swf)|*.swf| All File(*.*)|*.*|"

'åÐÇ ÇáãÊÍæá áßí íÊã ÇÙåÇÑ ÌãíÚ ÇáãáÝÇÊ ÍÊì ÇáãÎÝíÉ

.Flags = cdlOFNHideReadOnly Or cdlOFNFileMustExist Or cdlOFNPathMustExist

'íÊã ÊÓãíÉ ÚäæÇä ãÑÈÚ ÇáÝÊÍ

.DialogTitle = "Open Flash File"

'íÊã ÊÕÝíÑ ÇáÇÓã ÇáÇÈÊÏÇÆí

.FileName = ""

'íÊã ÝÊÍ ÇáäãæÐÌ Çæ ãÑÈÚ ÇáÍæÇÑ ÝÊÍ

.ShowOpen

'Ýí ÍÇá áã íÊã ÝÊÍ ÇÓã ãáÝ íÊã ÇáÎÑæÌ ãä ÇáÇÌÑÇÁ

If .FileName = "" Then Exit Sub

'íÊã ÇÓäÇÏ ÇÓã ÇáãáÝ Çáì ÇáãÊÛíÑ ÇáÎÇÕ ÈÇÓã ÇáãáÝ

ShockwaveFlash1.Movie = .FileName

End With

Mnu_File_Close.Enabled = True

Mnu_File_Print.Enabled = True

Mnu_View_100.Enabled = True

Mnu_View_All.Enabled = True

Mnu_View_ZoomIn.Enabled = True

Mnu_View_ZoomOut.Enabled = True

Mnu_Control_Play.Enabled = True

Mnu_Control_Rewind.Enabled = True

Mnu_Control_Forward.Enabled = True

Mnu_Control_Back.Enabled = True

Mnu_Control_Loop.Enabled = True

Mnu_Control_Play.Checked = True

Mnu_Control_Rewind.Checked = False

End Sub

Private Sub Mnu_File_Print_Click()

PrintForm

End Sub

Private Sub Mnu_Help_About_Click()

Form2.Show vbModal

End Sub

Private Sub Mnu_View_100_Click()

If Mnu_View_100.Checked = True Then Exit Sub

Mnu_View_100.Checked = True

Mnu_View_All.Checked = False

ShockwaveFlash1.ScaleMode = 3

End Sub

Private Sub Mnu_View_All_Click()

If Mnu_View_All.Checked = True Then Exit Sub

Mnu_View_100.Checked = False

Mnu_View_All.Checked = True

ShockwaveFlash1.ScaleMode = 4

End Sub

Private Sub Mnu_View_ExicatFit_Click()

End Sub

Private Sub Mnu_View_FullScreen_Click(Index As Integer)

Me.WindowState = vbMaximized

End Sub

Private Sub Mnu_View_HighQuality_Click()

If Mnu_View_HighQuality.Checked = True Then Exit Sub

Mnu_View_Low.Checked = False

Mnu_View_Medium.Checked = False

Mnu_View_HighQuality.Checked = True

ShockwaveFlash1.Quality = 1

End Sub

Private Sub Mnu_View_Low_Click()

If Mnu_View_Low.Checked = True Then Exit Sub

Mnu_View_Low.Checked = True

Mnu_View_Medium.Checked = False

Mnu_View_HighQuality.Checked = False

ShockwaveFlash1.Quality = 0

End Sub

Private Sub Mnu_View_Medium_Click()

If Mnu_View_Medium.Checked = True Then Exit Sub

Mnu_View_Low.Checked = False

Mnu_View_Medium.Checked = True

Mnu_View_HighQuality.Checked = False

ShockwaveFlash1.Quality = 3

End Sub

Private Sub Mnu_View_ZoomIn_Click()

With ShockwaveFlash1

.Width = .Width / 2

.Height = .Height / 2

End With

With Me

.Width = ShockwaveFlash1.Width

.Height = ShockwaveFlash1.Height

End With

End Sub

Private Sub Timer1_Timer()

End Sub

Private Sub Mnu_View_ZoomOut_Click()

With ShockwaveFlash1

.Width = .Width * 2

.Height = .Height * 2

End With

With Me

.Width = ShockwaveFlash1.Width

.Height = ShockwaveFlash1.Height

End With

End Sub

'-----------------------------------------------------

' هذا الكود لتحريك الفريم او الصوره

' Put this Code in General

Dim I%, X%, Delay%

Private Sub Command1_Click()

For X = 5000 To 6000 Step 5

Call RunAway(X)

Next X

For I = 10 To -6000 Step 5

Call RunAway(X)

Next I

End Sub

Private Sub RunAway(X As Integer)

Frame1.Left = X ' frameRight.Left = X

For Delay = 1 To 10000

Next Delay

End Sub

أداة Imagelist ووضع الصور فيها

Private Sub imgPrev_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Set imgPrev.Picture = ImageList1.ListImages(14).Picture

End Sub

Private Sub imgPrev_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Set imgPrev.Picture = ImageList1.ListImages(13).Picture

End Sub

For Scoll Tilte Form:

==============

Private Sub cbScroll_Click()

If cbScroll.Value = vbChecked Then

frmMain.bScrollTitle = True

Else

frmMain.bScrollTitle = False

End If

End Sub

If frmMain.bScrollTitle Then

If sFormTitle <> "" Then

'FIXIT: Replace 'Left' function with 'Left$' function FixIT90210ae-R9757-R1B8ZE

'FIXIT: Replace 'Right' function with 'Right$' function FixIT90210ae-R9757-R1B8ZE

sFormTitle = Right(sFormTitle, Len(sFormTitle) - 1) & Left(sFormTitle, 1)

End If

frmMain.Caption = sFormTitle

End If

Private Sub_Timer1.timer()

If MediaPlayer1.playState <> mpClosed And MediaPlayer1.playState <> mpStopped Then

Label2.Caption = sStatus & SecondsToTime(MediaPlayer1.currentPosition) & "/" & SecondsToTime(MediaPlayer1.duration)

Else

Label2.Caption = sStatus & "0:00/0:00"

End If

If Round(MediaPlayer1.currentPosition, 0) >= Fix(MediaPlayer1.duration) Then

imgNext_Click

End If

End sub

هذا الكود لنسخ اداة Image1 على الفورم

Dim NewElement As Integer

Private Sub Form_Click()

Load Image1(NewElement)

Image1(NewElement).Visible = True

Image1(NewElement).Top = Image1(NewElement - 1).Top

Image1(NewElement).Left = Image1(NewElement - 1).Left + 495

NewElement = NewElement + 1

'==================================================

'For Random Placement use this code:

'Image1(NewElement).Top = CInt(Form1.Height * Rnd)

'Image1(NewElement).Left = CInt(Form1.Width * Rnd)

'==================================================

'You can also use textboxes, command buttons.. everything"

End Sub

Private Sub Form_Load()

NewElement = 1

End Sub

===================================================

' عدم استخدام الماوس على فورم 1 وقت ظهور فورم 2

Private Sub Command1_Click()

Dim frm As New Form2

frm.Show vbModal, Me

End Sub

===================================================

كود لالغاء غلق الفورم من الاكس

Private Sub Form_UnLoad()

Cancel=1

End Sub

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

مشكور ع الجهد الرائع

تحياتي

ياريت تبقى تستعمل الـ Code Tags

[code]'Your VB Code[ /code]