أكواد كثيرة جداً ومفيدة

مغلقاستطلاع

بدأه en_gold في 4 أبريل 2003 · 23 رد · 2,381 مشاهدة · في لغة Ms Visual Basic 6 وما قبلها من إصدارات

مشاركة: واتساب X فيسبوك تيليجرام

استطلاع

11 مشارك في التصويت

????? ????????? ???? ??????

??? ???5 صوت · 45%

???5 صوت · 45%

?? ???0 صوت · 0%

???1 صوت · 9%

#14 أبريل 2003 في 00:08 صاحب الموضوع

هذا كود جعل النافذة تشع

ضع هذا الكود في الموديل

Private Declare Function FlashWindow Lib "user32" Alias "FlashWindow" (ByVal hWnd as long, ByVal bInvert as long) as long

أما هذا الكود ففي التايمر

Dim nReturnValue as Integer

nReturnValue = FlashWindow(form1.hWnd, true)

وهذا كود جعل الأيقونة عند الساعة في شريط المهام

عليك ما يلي

Add an icon to the system tray, and recognize when the icon is clicked or hoovered over

ضع هذا الكود في الموديل

Private Type NOTIFYICONDATA

cbSize As Long

hWnd As Long

uId As Long

uFlags As Long

uCallBackMessage As Long

hIcon As Long

szTip As String * 64

End Type

'Declare the constants for the API function. These constants can be

'found in the header file Shellapi.h.

'The following constants are the messages sent to the

'Shell_NotifyIcon function to add, modify, or delete an icon from the

'taskbar status area.

Private Const NIM_ADD = &H0

Private Const NIM_MODIFY = &H1

Private Const NIM_DELETE = &H2

'The following constant is the message sent when a mouse event occurs

'within the rectangular boundaries of the icon in the taskbar status

'area.

Private Const WM_MOUSEMOVE = &H200

'The following constants are the flags that indicate the valid

'members of the NOTIFYICONDATA data type.

Private Const NIF_MESSAGE = &H1

Private Const NIF_ICON = &H2

Private Const NIF_TIP = &H4

'The following constants are used to determine the mouse input on the

'the icon in the taskbar status area.

'Left-click constants.

Private Const WM_LBUTTONDBLCLK = &H203 'Double-click

Private Const WM_LBUTTONDOWN = &H201 'Button down

Private Const WM_LBUTTONUP = &H202 'Button up

'Right-click constants.

Private Const WM_RBUTTONDBLCLK = &H206 'Double-click

Private Const WM_RBUTTONDOWN = &H204 'Button down

Private Const WM_RBUTTONUP = &H205 'Button up

'Declare the API function call.

Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

'Dimension a variable as the user-defined data type.

Dim nid As NOTIFYICONDATA

ثم استخدم هذا الكود

Private Sub Command1_Click()

'Click this button to add an icon to the taskbar status area.

'Set the individual values of the NOTIFYICONDATA data type.

nid.cbSize = Len(nid)

nid.hWnd = Form1.hWnd

nid.uId = vbNull

nid.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE

nid.uCallBackMessage = WM_MOUSEMOVE

nid.hIcon = Form1.Icon

nid.szTip = "Taskbar Status Area Sample Program" & vbNullChar

'Call the Shell_NotifyIcon function to add the icon to the taskbar

'status area.

Shell_NotifyIcon NIM_ADD, nid

End Sub

Private Sub Command2_Click()

'Click this button to delete the added icon from the taskbar

'status area by calling the Shell_NotifyIcon function.

Shell_NotifyIcon NIM_DELETE, nid

End Sub

Private Sub Form_Load()

'Set the captions of the command button when the form loads.

Command1.Caption = "Add an Icon"

Command2.Caption = "Delete Icon"

End Sub

Private Sub Form_Terminate()

'Delete the added icon from the taskbar status area when the

'program ends.

Shell_NotifyIcon NIM_DELETE, nid

End Sub

Private Sub Form_MouseMove _

(Button As Integer, _

Shift As Integer, _

X As Single, _

Y As Single)

'Event occurs when the mouse pointer is within the rectangular

'boundaries of the icon in the taskbar status area.

Dim msg As Long

Dim sFilter As String

msg = X / Screen.TwipsPerPixelX

Select Case msg

Case WM_LBUTTONDOWN

Case WM_LBUTTONUP

Case WM_LBUTTONDBLCLK

CommonDialog1.DialogTitle = "Select an Icon"

sFilter = "Icon Files (*.ico)|*.ico"

sFilter = sFilter & "|All Files (*.*)|*.*"

CommonDialog1.Filter = sFilter

CommonDialog1.ShowOpen

If CommonDialog1.FileName <> "" Then

Form1.Icon = LoadPicture(CommonDialog1.FileName)

nid.hIcon = Form1.Icon

Shell_NotifyIcon NIM_MODIFY, nid

End If

Case WM_RBUTTONDOWN

Dim ToolTipString As String

ToolTipString = InputBox("Enter the new ToolTip:", "Change ToolTip")

If ToolTipString <> "" Then

nid.szTip = ToolTipString & vbNullChar

Shell_NotifyIcon NIM_MODIFY, nid

End If

Case WM_RBUTTONUP

Case WM_RBUTTONDBLCLK

End Select

End Sub

ولكم مني هذا الملف البسيط الذي هو عبارة عن ساعة حائط

انتظروني في أكواد قادمة

أخوكم : إيناس حسن:cool::cool:(f)

analog_clock.zip

#24 أبريل 2003 في 19:14

شكرا لك يا أخي :) en_gold :) على هذه الجهود الجميلة ننتظر منك المزيد .

أخوك : سعد (f)

#35 أبريل 2003 في 21:42

thank you

#45 أبريل 2003 في 23:17

شكراً :b1 وعلى فكرة ساعتك حلوة (clock) ولكن تحتاج بعض الديكور وتصير أحلى وأحلى(f)(f)(f)

#57 أبريل 2003 في 15:47

شكراً لكم يا إخواني

#67 أبريل 2003 في 15:50

والآن إليكم هذه الأكواد الأخرى وأرجو أن تنال إعجابكم

هذا الكود لوضع صورة في menu

ضع هذا في الموديل

Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

Public Const MF_BITMAP = &H4&

Type MENUITEMINFO

cbSize As Long

fMask As Long

fType As Long

fState As Long

wID As Long

hSubMenu As Long

hbmpChecked As Long

hbmpUnchecked As Long

dwItemData As Long

dwTypeData As String

cch As Long

End Type

Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long

Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Boolean

Public Const MIIM_ID = &H2

Public Const MIIM_TYPE = &H10

Public Const MFT_STRING = &H0&

أما هذا الكود ضعه في المكان المناسب

'To start things off right, just add a form to a project (or just start a new project). Add a picturebox control. Set 'Autosize' to 'True' with a bitmap (not an Icon) at a maximum of 13X13. Add a comandbutton with the following code:

Private Sub Command1_Click()

'Get the menuhandle of your app

hMenu& = GetMenu(Form1.hwnd)

'Get the handle of the first submenu (Hello)

hSubMenu& = GetSubMenu(hMenu&, 0)

'Get the menuId of the first entry (Bitmap)

hID& = GetMenuItemID(hSubMenu&, 0)

'Add the bitmap

SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture1.Picture

'You can add two bitmaps to a menuentry one for the checked and one for the unchecked state.

End Sub

*****************************

هذا الكود لإغلاق السواقة وفتحها

الموديل:

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

احزر أين تضعه

Dim lngReturn As Long

Dim strReturn As Long

'To open the CD door, use this code:

lngReturn = mciSendString("set CDAudio door open", strReturn, 127, 0)

'To close the CD door, use this code:

lngReturn = mciSendString("set CDAudio door closed", strReturn, 127, 0)

********************

انتظروني في أكواد أخرى

أخوكم إيناس حسن:cool::cool:

#77 أبريل 2003 في 16:02

شكراً لكم أصدقائي على دعمكم الرائع وهذه أكواد جديدة

هذا الكود لإظهار خصائص سطح المكتب

Dim dblReturn As Double

dblReturn = Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5)

بسيط جدا

****************************

لأخذ صورة عن سطح المكتب

Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long

أما في الفورم

PaintDesktop Me.hdc

*******************************

لرسم خط ثلاثي أبعاد

'* Function: EtchedLine(frmEtch As Form, ByVal intX1 As Integer, ByVal intY1 As Integer, ByVal intLength As Integer)

'*************************************************************************

'* Description: Draws an 'etched' line upon the specified form starting

'* at the X,Y location passed in and of the specified length.

'* Coordinates are in the current ScaleMode of the passed

'* in form.

'*************************************************************************

'* Parameters: [frmEtch] - form to draw the line upon

'* [intX1] - starting horizontal of line

'* [intY1] - starting vertical of line

'* [intLength] - length of the line

'*************************************************************************

'* Notes:

'*************************************************************************

'* Returns:

'*************************************************************************

Sub EtchedLine(frmEtch As Form, ByVal intX1 As Integer, ByVal intY1 As Integer, ByVal intLength As Integer)

Const lWHITE& = vb3DHighlight

Const lGRAY& = vb3DShadow

frmEtch.Line (intX1, intY1)-(intX1 + intLength, intY1), lGRAY

frmEtch.Line (frmEtch.CurrentX + 5, intY1 + 20)-(intX1 - 5, intY1 + 20), lWHITE

End Sub

*************************

أخوكم إيناس حسن:cool::cool:(gift)

#87 أبريل 2003 في 16:05

هذا كود هاتف بسيط

هçê‎.zip

#97 أبريل 2003 في 16:06

هذا كود تشغيل ال cd

êôûيل_çل_cd.zip

#108 أبريل 2003 في 00:13

ما أروعك(gift)

#118 أبريل 2003 في 02:37

يعطيك الف عافية اخوي en_gold

مجهود تشكر علية تقبل تحياتي ,,,,,,,,,,

#128 أبريل 2003 في 03:35

يعطيك العافية والى الامام

Do as I say, not as I do

We are Anonymous. We are Legion. We don't forgive. We don't forget

#139 أبريل 2003 في 15:30

جزاك الله خيراً

#1410 أبريل 2003 في 23:20

شكراً لكم يا أصدقاء:cool:

#1511 أبريل 2003 في 00:40

شكرا على جهودك .

أخوك : سعد (f)

#1611 أبريل 2003 في 00:47

ربنا يزيدك من علمة وشكرا لك (f)

وَقُل رَّبِّ زِدْنِي عِلْماً

#1711 أبريل 2003 في 13:42

عفواً أخي سعد(f)

#1811 أبريل 2003 في 15:25

(f)كود للتحكم في حركة الماوس(f)

'This project needs 2 Buttons

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

#1911 أبريل 2003 في 15:27

(f)كود لمعرفة اسم الكمبيوتر(f)

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

#2011 أبريل 2003 في 15:28

في انتظار أكوادك المميزة أخي en_gold:D

#2126 أبريل 2003 في 16:25

أشكرك على هذه الأكواد أخ عبدالله:cool:

#2226 أبريل 2003 في 20:40

يعطيك العافية

#2326 أبريل 2003 في 23:58

مشكور اخي على جهودك..

#2427 أبريل 2003 في 05:51

100 100 و ننتظر المزيد..

هذا الموضوع مغلق.

مواضيع مشابهة

كتب كثيرة ومفيدة ومتعددة المجالات1 رد · 26 مايو 2002
اكواد كثيرة جدا4 رد · 23 مايو 2003
موقع رائع لكتب كثيرة ومفيدة جدا للفيجوال بيسك وغيرها من اللغات المهمة2 رد · 2 مايو 2008
أكواد كثيرة للجافا2 رد · 22 ديسمبر 2004
مجموعة برامج قيمة جدا ومفيدة جدا جدا جدا7 رد · 19 أكتوبر 2005
أكواد مهمة جداً6 رد · 15 أبريل 2006

أكواد كثيرة جداً ومفيدة

استطلاع

????? ????????? ???? ??????

مواضيع مشابهة

عدد الزوار حالياً