نمونه کد - ترفند - کامپوننت برای ^Visual Basic^

MnavidM

Active Member
سلام.

این تاپیک رو به این منظور ایجاد کردم که هر کدام از دوستان خواستند که "نمونه کد - ترفند - کامپوننت برای ^ Visual Basic ^ "
قرار بدند از اینجا استفاده کنند .

و لطفا در این تاپیک از زدن پست های بی استفاده خودداری کنید .

:1: - اگر خواستید تشکر کنید , می تونید از دکمه تشکر پایین هر پست استفاده کنید.
:2: - اگر در مورد کد ها و ... سوال داشتید در تاپیکی جدا سوال خود رو با موضوعی مناسب مطرح کنید.
:3: - هر پستی که در اینجا می زنید , موضوعش را مشخص کنید.
:4: - تا جایی که امکان داره , توضیح مختصری از هر خط کد آموزشی بنویسید(اگر هم نباشه مشکلی نیست).
:5: - از ساختار زیر برای آموزش استفاده کنید .


موضوع : ---
تست شده در ویژوال بیسیک: ---
کد :

کد:
code ro inja benevisid

توضیحاتی در مورد کد : ------
---------------
-----------

:6: - البته بسته به نیاز می تونید ساختار رو تغییر بدید و موارد دیگری رو هم اضافه کنید , اما موارد بالا از یادتان نرود.

:7: - اگر هم سوال , نظر و یا پیشنهادی در این مورد داشتید توسط پیغام خصوصی با من تماس بگیرید.
:8: - موفق باشید.

نوید مردوخ روحانی - 16-04-1384
 

Mikhak

Active Member
بدست آوردن اطلاعاتي در مورد درايوهاي سيستم از جمله نوع ، تعداد ، اسامي

براي اين برنامه كافيه يه فرم جديد درست كنين و يه ليست باكس رو فرمتون قرار بدين و كد زير رو به برنامه تون وارد كنين
کد:
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Sub GetDrives(lst1 As ListBox)
'get available drives on computer
Dim strsave As String
Dim ret As Long
Dim i As Byte
Dim drive As String
strsave = String(255, Chr$(0))
ret = GetLogicalDriveStrings(255, strsave)
lst1.Clear
For i = 0 To 100
    If Left$(strsave, InStr(1, strsave, Chr$(0))) = Chr$(0) Then Exit For
        drive = Left$(strsave, InStr(1, strsave, Chr$(0)) - 1)
        strsave = Right$(strsave, Len(strsave) - InStr(1, strsave, Chr$(0)))
    Select Case GetDriveType(drive)
        Case DRIVE_REMOVABLE
            lst1.AddItem UCase$(drive) & vbTab & "(Removable Drive)"
        Case DRIVE_FIXED
            lst1.AddItem UCase$(drive) & vbTab & "(Fixed Drive)"
        Case DRIVE_REMOTE
            lst1.AddItem UCase$(drive) & vbTab & "(Remote Drive)"
        Case DRIVE_CDROM
            lst1.AddItem UCase$(drive) & vbTab & "(CDROM Drive)"
        Case DRIVE_RAMDISK
            lst1.AddItem UCase$(drive) & vbTab & "(RAM Disk)"
        Case Else
    End Select
Next i
lst1.ListIndex = 0
End Sub

Private Sub Form_Load()
GetDrives List1
End Sub
-----------------------
سينا
 

Mikhak

Active Member
غير فعال كردن task manager

يه فرم جديد ايجاد كنين و يه دونه چك باكس بهش اضافه كنين و اسم چك باكس بزارين بمونه همون Check1
بعد كد زير رو به برنامتون وارد كنين
کد:
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Const REG_SZ = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const HKEY_CURRENT_USER = &H80000001

Private Sub SaveStringWORD(hKey As Long, strPath As String, strValue As String, strData As String)
'----------------------------------------------------------------------------
'Argument       :   Handlekey, Name of the Value in side the key
'Return Value   :   Nil
'Function       :   To store the value into a key in the Registry
'Comments       :   None
'----------------------------------------------------------------------------

    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Set the key's value
    RegSetValueEx Ret, strValue, 0, REG_DWORD, CLng(strData), 4
    'close the key
    RegCloseKey Ret
End Sub

Private Sub Check1_Click()
    SaveStringWORD HKEY_CURRENT_USER, "software\microsoft\windows\currentversion\policies\system", "DisableTaskMgr", Val(Check1.Value)
End Sub

Private Sub Form_Load()
    Check1.Caption = "Disable Task Manager"
End Sub
------------------------------
سينا
 

paramond

Member
ماشين حساب

اين يک ماشی حساب کوچولو هست که خودم نوشتم البته زبانشVb.net نميدونم ميشه اينجاا گذاشت يا نه

کد:
''Y  Mehdi
'' Oefening 
Imports System
Imports System.Windows.Forms
Imports Microsoft.VisualBasic
Imports System.Drawing
Module Calc
Private WithEvents Tx1 As New Textbox      'text box	
Class reken
	Inherits System.Windows.Forms.Form
	
	Public Shared Sub Main()
		Application.Run(New reken())
	End Sub
	
	'form setting
	Public Sub New()
		Text = "Hi"
		Name = "Mehdi Rekening"
		Width = 400
		Height = 400
		MaximizeBox = False
		MinimizeBox = False
		HelpButton = True
		FormBorderStyle = FormBorderStyle.FixedDialog
		'BackGroundImage = Image.FromFile ("Calc3.Bmp")
		Txbx()
		Bttn()
		
		
		
	End Sub
	
	'text box setting
	Private Sub Txbx()
		With Tx1
			.Font = New Font("Arial", 10)
			.MaxLength = 10
			.TextAlign = HorizontalAlignment.Right
			.Readonly = True
			.Multiline = True
			.Acceptsreturn = True
			.Acceptstab = True
			.Wordwrap = True
			.Text = "0"
			.Height = 25
			.Width = 340
			.Top = 30
			.Left = 30
		End With
		Me.Controls.Add(Tx1)
	End Sub
	
	'button declaratie
	Private WithEvents button_plus As New Button
	Private WithEvents button_mall As New Button
	Private WithEvents button_min As New Button
	Private WithEvents button_delen As New Button
	Private WithEvents button_result As New Button
	Private WithEvents button_clear As New Button
	'_change templet button
	Private WithEvents skin_changer As New Button()   
	
	'set buttons
	Private Sub Bttn()
		'button 1-9 declaratie 
		Dim i As Integer = 0
		Dim j As Integer = 90
		Dim g As Integer = 40
		For i = 0 To 8 
			If i = 3 or i = 6
				j = j + 40
				g = 40
			End If 
			Dim btn1_10 As New creat_button
			'(text , top , left , past number)
			btn1_10.general_button(i+1 ,j, g, i+1)
			Controls.Add(btn1_10.button_G)
			g = g + 80
		Next i
		
		'button 0 declaratie
		Dim btn0 As New creat_button
		'(text , top , left , past if click)
		btn0.general_button(0 ,210, 120, 0)
		Controls.Add(btn0.button_G)
		
		With skin_changer
			.flatstyle = flatstyle.system
			.width = 40
			.height = 20
			.top = 4
			.left = 4
			.backcolor = backcolor.red
		End With
		With button_plus
			.Text = "+"
			.Top = 90
			.Left = 40 + 240 
			.FlatStyle = FlatStyle.System
		End With						
		With button_mall
			.Text = "X"
			.Top = 210
			.Left = 40 + 240
			.FlatStyle = FlatStyle.System
		End With		
		With button_min
			.Text = "__"
			.Top = 170
			.Left = 40 + 240
			.FlatStyle = FlatStyle.System
		End With
		With button_delen
			.Text = "/"
			.Top = 130
			.Left = 40 + 240
			.FlatStyle = FlatStyle.System
		End With		
		With button_result
			.Text = "="
			.Top = 210
			.Left = 40 + 160
			.FlatStyle = FlatStyle.System
		End With	
		With button_clear
			.Text = "C"
			.Top = 250
			.Left = 40
			.Width = 200 + 115
			.FlatStyle = FlatStyle.System
		End With	
		
		'add buttons
		Controls.Add(skin_changer)
		Controls.Add(button_plus)
		Controls.Add(button_mall)
		Controls.Add(button_min)
		Controls.Add(button_result)
		Controls.Add(button_delen)
		Controls.Add(button_clear)
		
	End Sub
	
	Dim Sym As New Integer
	Dim Number1 As New Double
	Dim Number2 As New Double
	
	'buttons click
	'plus
	Private Sub Klick_button_plus (Sender As Object,E As EvenTargs) Handles button_plus.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 1
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	' /
	Private Sub Klick_button_delen(Sender As Object,E As EvenTargs) Handles button_delen.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 2
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	' min
	Private Sub Klick_button_min(Sender As Object,E As EvenTargs) Handles button_min.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 3
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	'x
	Private Sub Klick_button_mall(Sender As Object,E As EvenTargs) Handles button_mall.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 4
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	'clear
	Private Sub Klick_button_clear(Sender As Object,E As EvenTargs) Handles button_clear.Click
		Number1 = 0
		Number2 = 0
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	'=
	Private Sub Klick_button_result(Sender As Object,E As EvenTargs) Handles button_result.Click
		Number2 = Tx1.Text
		If Sym = 1
			Tx1.Text = Number1 + Number2
		End If
		If Sym = 2
			Tx1.Text = Number1 / Number2
		End If
		If Sym = 3
			Tx1.Text = Number1 - Number2
		End If
		If Sym = 4
			Tx1.Text = Number1 * Number2
		End If
	End Sub
	Dim Number3 As Integer = 0
	'templet
	Private Sub skin_changer_click(Sender As Object,E As EvenTargs) Handles skin_changer.Click
		Number3 = Number3 + 1

		If Number3 = 1
			'Backgroundimage = Image.Fromfile("Calc.Bmp")
		End If
		If Number3 = 2
			'Backgroundimage = Image.Fromfile("Calc2.Bmp")
		End If
		If Number3 = 3
			'Backgroundimage = Image.Fromfile("Calc3.Bmp")
		End If
		If Number3 = 4
			'Backgroundimage = Image.Fromfile("Calc4.Bmp")
		End If
		If Number3 = 5
			'Backgroundimage = Image.Fromfile("Calc5.Bmp")
		End If
		If Number3 = 5
			Number3 = 0
		End If
	End Sub
End Class

Class creat_button
	Public WithEvents button_G As New Button
	Dim Past_number1 As Integer
	
	Public Sub general_button(text1 As String, Top1 As _
	Integer , left1 As Integer, past_number As Integer)
		
		With button_G
			.FlatStyle = FlatStyle.System
			.Text = text1
			.Top = top1
			.Left = left1
		End With
		Past_number1 = past_number
	End Sub
	
	Private Sub click_button_G(sender As Object,e As EvenTargs)Handles button_G.click
		tx1.AppendText(Past_number1)
	End Sub
	
End Class
End Module
 

paramond

Member
ماشين حساب

اين هم يک ماشين حساب ديگه که کارهاش کملاً مثل قبلی هست ولی طريقه برنامه نويسيش فرق داره
من که شخصاً اون قبلی رو بيشتر ميپسندم

کد:
''Y Mehdi
'' Oefening 
Imports System
Imports System.Windows.Forms
Imports Microsoft.VisualBasic
Imports System.Drawing

Class reken
	Inherits System.Windows.Forms.Form
	
	Public Shared Sub Main()
		Application.Run(New reken())
	End Sub
	'form setting
	Public Sub New()
		Text = "Hi"
		Name = "Mehdi Rekening"

		Width = 400
		Height = 400
		MaximizeBox = False
		MinimizeBox = False
		HelpButton = True
		FormBorderStyle = FormBorderStyle.FixedDialog
		'BackGroundImage = Image.FromFile ("Calc3.Bmp")
		Txbx()
		Bttn()
	End Sub
	Private WithEvents Tx1 As New Textbox      'text box
	Private WithEvents Mehdi As New Button()   'change templet button
	'text box setting
	Private Sub Txbx()
		With mehdi
			.flatstyle = flatstyle.system
			.width = 40
			.height = 20
			.top = 4
			.left = 4
			.backcolor = backcolor.red
		End With
		Controls.Add(Mehdi)
		With Tx1
			.Font = New Font("Arial", 10)
			.MaxLength = 50
			.TextAlign = HorizontalAlignment.Right
			.Readonly = True
			.Multiline = True
			.Acceptsreturn = True
			.Acceptstab = True
			.Wordwrap = True
			.Text = "0"
			.Height = 25
			.Width = 340
			.Top = 30
			.Left = 30
		End With
		Me.Controls.Add(Tx1)
	End Sub
	
	'button
	
	Private WithEvents Btn1 As New Button
	Private WithEvents Btn2 As New Button
	Private WithEvents Btn3 As New Button
	Private WithEvents Btn4 As New Button
	Private WithEvents Btn5 As New Button
	Private WithEvents Btn6 As New Button
	Private WithEvents Btn7 As New Button
	Private WithEvents Btn8 As New Button
	Private WithEvents Btn9 As New Button
	Private WithEvents Btn10 As New Button
	Private WithEvents Btn11 As New Button
	Private WithEvents Btn12 As New Button
	Private WithEvents Btn13 As New Button
	Private WithEvents Btn14 As New Button
	Private WithEvents Btn15 As New Button
	Private WithEvents Btn16 As New Button
	
	'set buttons
	
	Private Sub Bttn()
		With Btn1
			.Text = "1"
			.Top = 90
			.Left = 40
			.FlatStyle = FlatStyle.system
		End With		
		With Btn2
			.Text = "2"
			.Top = 90
			.Left = 40 + 80
			.FlatStyle = FlatStyle.System
		End With		
		With Btn3
			.Text = "3"
			.Top = 90
			.Left = 40 + 160
			.FlatStyle = FlatStyle.System
		End With		
		With Btn4
			.Text = "+"
			.Top = 90
			.Left = 40 + 240 
			.FlatStyle = FlatStyle.System
		End With		
		With Btn5
			.Text = "4"
			.Top = 130
			.Left = 40 
			.FlatStyle = FlatStyle.System
		End With		
		With Btn6
			.Text = "5"
			.Top = 130
			.Left = 40 + 80
			.FlatStyle = FlatStyle.System
		End With		
		With Btn7
			.Text = "6"
			.Top = 130
			.Left = 40 +160
			.FlatStyle = FlatStyle.System
		End With		
		With Btn8
			.Text = "7"
			.Top = 170
			.Left = 40 
			.FlatStyle = FlatStyle.System
		End With		
		With Btn9
			.Text = "8"
			.Top = 170
			.Left = 40 + 80
			.FlatStyle = FlatStyle.System
		End With		
		With Btn10
			.Text = "9"
			.Top = 170
			.Left = 40 + 160
			.FlatStyle = FlatStyle.System
		End With		
		With Btn11
			.Text = "0"
			.Top = 210
			.Left = 40 + 80
			.FlatStyle = FlatStyle.System
		End With		
		With Btn12
			.Text = "X"
			.Top = 210
			.Left = 40 + 240
			.FlatStyle = FlatStyle.System
		End With		
		With Btn13
			.Text = "__"
			.Top = 170
			.Left = 40 + 240
			.FlatStyle = FlatStyle.System
		End With
		With Btn14
			.Text = "/"
			.Top = 130
			.Left = 40 + 240
			.FlatStyle = FlatStyle.System
		End With		
		With Btn15
			.Text = "="
			.Top = 210
			.Left = 40 + 160
			.FlatStyle = FlatStyle.System
		End With	
		With Btn16
			.Text = "C"
			.Top = 250
			.Left = 40
			.Width = 200 + 115
			.FlatStyle = FlatStyle.System
		End With	
		
		'add buttons
		
		Controls.Add(Btn1)
		Controls.Add(Btn2)
		Controls.Add(Btn3)
		Controls.Add(Btn4)
		Controls.Add(Btn5)
		Controls.Add(Btn6)
		Controls.Add(Btn7)
		Controls.Add(Btn8)
		Controls.Add(Btn9)
		Controls.Add(Btn10)
		Controls.Add(Btn11)
		Controls.Add(Btn12)
		Controls.Add(Btn13)
		Controls.Add(Btn14)
		Controls.Add(Btn15)
		Controls.Add(Btn16)
	End Sub
	Dim Sym As New Integer
	Dim Number1 As New Double
	Dim Number2 As New Double
	
	'buttons click
	'number 1
	Private Sub Klick1(Sender As Object,E As EvenTargs) Handles Btn1.click
		Tx1.Appendtext("1")
		
	End Sub
	'number 2
	Private Sub Klick2(Sender As Object,E As EvenTargs) Handles Btn2.Click
		Tx1.Appendtext("2")
	End Sub
	'number 3
	Private Sub Klick3(Sender As Object,E As EvenTargs) Handles Btn3.Click
		Tx1.Appendtext("3")
	End Sub
	'plus
	Private Sub Klick4(Sender As Object,E As EvenTargs) Handles Btn4.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 1
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	'number 4
	Private Sub Klick5(Sender As Object,E As EvenTargs) Handles Btn5.Click
		Tx1.Appendtext("4")
	End Sub
	'number 5
	Private Sub Klick6(Sender As Object,E As EvenTargs) Handles Btn6.Click
		Tx1.Appendtext("5")
	End Sub
	'number 6
	Private Sub Klick7(Sender As Object,E As EvenTargs) Handles Btn7.Click
		Tx1.Appendtext("6")
	End Sub
	'number 7
	Private Sub Klick8(Sender As Object,E As EvenTargs) Handles Btn8.Click
		Tx1.Appendtext("7")
	End Sub
	'number 8
	Private Sub Klick9(Sender As Object,E As EvenTargs) Handles Btn9.Click
		Tx1.Appendtext("8")
	End Sub
	'number 9
	Private Sub Klick10(Sender As Object,E As EvenTargs) Handles Btn10.Click
		Tx1.Appendtext("9")
	End Sub
	'number 0
	Private Sub Klick11(Sender As Object,E As EvenTargs) Handles Btn11.Click
		Tx1.Appendtext("0")
	End Sub
	' /
	Private Sub Klick12(Sender As Object,E As EvenTargs) Handles Btn14.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 2
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	
	' min
	Private Sub Klick13(Sender As Object,E As EvenTargs) Handles Btn13.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 3
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	'x
	Private Sub Klick14(Sender As Object,E As EvenTargs) Handles Btn12.Click
		Number1 = 0
		Number1 = Tx1.Text
		Sym = 4
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	'clear
	Private Sub Klick16(Sender As Object,E As EvenTargs) Handles Btn16.Click
		Number1 = 0
		Number2 = 0
		Tx1.Clear
		Tx1.Text = 0
	End Sub
	'=
	Private Sub Klick15(Sender As Object,E As EvenTargs) Handles Btn15.Click
		Number2 = Tx1.Text
		If Sym = 1
			Tx1.Text = Number1 + Number2
		End If
		If Sym = 2
			Tx1.Text = Number1 / Number2
		End If
		If Sym = 3
			Tx1.Text = Number1 - Number2
		End If
		If Sym = 4
			Tx1.Text = Number1 * Number2
		End If
	End Sub
	Dim Number3 As Integer = 0
	'templet
	Private Sub Checkboxclick(Sender As Object,E As EvenTargs) Handles Mehdi.Click
		Number3 = Number3 + 1

		If Number3 = 1
			'Backgroundimage = Image.Fromfile("Calc.Bmp")
		End If
		If Number3 = 2
			'Backgroundimage = Image.Fromfile("Calc2.Bmp")
		End If
		If Number3 = 3
			'Backgroundimage = Image.Fromfile("Calc3.Bmp")
		End If
		If Number3 = 4
			'Backgroundimage = Image.Fromfile("Calc4.Bmp")
		End If
		If Number3 = 5
			'Backgroundimage = Image.Fromfile("Calc5.Bmp")
		End If
		If Number3 = 5
			Number3 = 0
		End If

	End Sub
End Class
 

Mikhak

Active Member
قرار دادن آيكون برنامه كنار ساعت ويندوز

موضوع : قرار دادن يك آيكون از برنامه ي نوشته شده كنار ساعت كوچيك كامپيوتر

يك پروژه جديد ايجاد كنين و يه ماژول جديد بسازين و همه ي اين كدها رو تو اون ماژول بزارين
کد:
Public Const WM_RBUTTONUP = &H205
Global Const WM_MOUSEMOVE = &H200
Global Const NIM_ADD = 0
Global Const NIM_DELETE = 2
Global Const NIM_MODIFY = 1
Global Const NIF_ICON = 2
Global Const NIF_MESSAGE = 1
Global Const ABM_GETTASKBARPOS = &H5
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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
Type APPBARDATA
cbSize As Long
hwnd As Long
uCallbackMessage As Long
uEdge As Long
rc As RECT
lParam As Long
End Type
Global Notify As NOTIFYICONDATA
Global BarData As APPBARDATA
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Sub AddIcon(Form1 As Form, IconID As Long, Icon As Object, ToolTip As String)
Dim Result As Long
BarData.cbSize = 36&
Result = SHAppBarMessage(ABM_GETTASKBARPOS, BarData)
Notify.cbSize = 88&
Notify.hwnd = Form1.hwnd
Notify.uID = IconID
Notify.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
Notify.uCallbackMessage = WM_MOUSEMOVE
Notify.hIcon = Icon
Notify.szTip = ToolTip & Chr$(0)
Result = Shell_NotifyIcon(NIM_ADD, Notify)
End Sub
Sub delIcon(IconID As Long)
Dim Result As Long
Notify.uID = IconID
Result = Shell_NotifyIcon(NIM_DELETE, Notify)
End Sub

حالا توي فرمتون هم يه متغير تعريف كنين يعني اين كد رو كپي كنين به اول فرمتون
کد:
Public IconObject As Object

بعدش توي تابع لود شدن فرمتون اين كدها ..
کد:
Set IconObject = Form1.Icon
AddIcon Form1, IconObject.Handle, IconObject, "TrayIcon"
Me.Popup.Visible = False

و تو تابع خارج شدن از فرم (unload) اين كدها رو وارد كنين
کد:
delIcon IconObject.Handle
delIcon Form1.Icon.Handle

حالا يه منو درست كنين و اسمش رو بزارين pupop بعد اينكه منو رو ساختين و چند تا زير شاخه بهش دادين اين كدها رو تو تابع mouse_move فرمتون كپي كنين
کد:
Static Message As Long
Message = X / Screen.TwipsPerPixelX
Select Case Message
Case WM_RBUTTONUP:
Me.PopupMenu Popup
End Select
اين كد براي اينه كه وقتي روي اون آيكون كنار ساعت راست كليك كنين يه منو باز بشه

موفق باشي :oops: ن
------------------------
سينا
 

Mikhak

Active Member
شناسايي فايل سيستم يا همون fat درايوها

موضوع : شناسايي نوع FAT درايو

برنامه ي 3 تا پست قبل اطلاعاتي راجع به درايو ها ميده ولي خيلي كم مثلا نوع FAT رو نميشناسه ولي اين برنامه علاوه بر شناسايي filesystem درايوها اطلاعات زير ر و هم به شما ميده
1- نام درايو
2- برچسب درايو
3- نوع فايل سيستم درايو
4- پرچمهاي فايل سيستم
5- نوع درايو
براي شروع يه فرم جديد اضافه كنين به اسم form1 و اجزاي زير رو به اون اضافه كنين
1- يك عدد listbox اسمش رو هم بزارين :drvInfo
2- يك عدد textbox اسمش رو هم بزارين : txtInfo
3- يك عدد command button اسمش رو هم بزارين cmdGetInfo
بعد كل كد زير رو به برنامه تون اضافه كنين
کد:
Option Explicit

Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_NO_ROOT_DIR = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6

Private Const FILE_CASE_PRESERVED_NAMES = &H2
Private Const FILE_CASE_SENSITIVE_SEARCH = &H1
Private Const FILE_UNICODE_ON_DISK = &H4
Private Const FILE_PERSISTENT_ACLS = &H8
Private Const FILE_FILE_COMPRESSION = &H10
Private Const FILE_VOLUME_IS_COMPRESSED = &H8000
Private Const FILE_SUPPORTS_ENCRYPTION = &H20000
Private Const FILE_SUPPORTS_OBJECT_IDS = &H10000
Private Const FILE_SUPPORTS_REPARSE_POINTS = &H80
Private Const FILE_SUPPORTS_SPARSE_FILES = &H40
Private Const FILE_VOLUME_QUOTAS = &H20

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 Const EM_SETTABSTOPS = &HCB
Private Sub cmdGetInfo_Click()
Dim volume_name As String
Dim file_system_name As String
Dim info_status As Long
Dim serial_number As Long
Dim max_component_length As Long
Dim file_system_flags As Long
Dim drive_name As String
Dim drive_type As Long
Dim txt As String
Dim pos As Integer

    txtInfo.Text = ""
    Screen.MousePointer = vbHourglass
    DoEvents

    volume_name = Space(256)
    file_system_name = Space(256)

    drive_name = drvInfo.Drive
    pos = InStr(drive_name, ":")
    If pos > 0 Then drive_name = Left$(drive_name, pos)
    If Right$(drive_name, 1) <> "\" Then drive_name = drive_name & "\"
    drive_type = GetDriveType(drive_name)

    info_status = GetVolumeInformation(drive_name, _
        volume_name, Len(volume_name), serial_number, _
        max_component_length, file_system_flags, _
        file_system_name, Len(file_system_name))

     volume_name = CleanString(volume_name)
     file_system_name = CleanString(file_system_name)
 
    txt = _
        "Drive Name:" & vbTab & drive_name & vbCrLf & _
        "Volume Name:" & vbTab & "'" & volume_name & "'" & vbCrLf & _
        "Serial Number:" & vbTab & serial_number & vbCrLf & _
        "Max Component Length:" & vbTab & max_component_length
    If max_component_length = 255 Then
        txt = txt & " (supports long file names)"
    End If
    txt = txt & vbCrLf & _
        "File System Flags:" & vbTab & file_system_flags & vbCrLf

    If file_system_flags And FILE_CASE_PRESERVED_NAMES Then
        txt = txt & vbTab & "Preserves Names" & vbCrLf
    End If
    If file_system_flags And FILE_CASE_SENSITIVE_SEARCH Then
        txt = txt & vbTab & "Case Sensitive Search" & vbCrLf
    End If
    If file_system_flags And FILE_UNICODE_ON_DISK Then
        txt = txt & vbTab & "Unicode On Disk" & vbCrLf
    End If
    If file_system_flags And FILE_PERSISTENT_ACLS Then
        txt = txt & vbTab & "Persistent ACLS" & vbCrLf
    End If
    If file_system_flags And FILE_FILE_COMPRESSION Then
        txt = txt & vbTab & "File Compression" & vbCrLf
    End If
    If file_system_flags And FILE_VOLUME_IS_COMPRESSED Then
        txt = txt & vbTab & "Volume Is Compressed" & vbCrLf
    End If
    If file_system_flags And FILE_SUPPORTS_ENCRYPTION Then
        txt = txt & vbTab & "Supports Encryption" & vbCrLf
    End If
    If file_system_flags And FILE_SUPPORTS_OBJECT_IDS Then
        txt = txt & vbTab & "Supports Object IDs" & vbCrLf
    End If
    If file_system_flags And FILE_SUPPORTS_REPARSE_POINTS Then
        txt = txt & vbTab & "Supports Reparse Points" & vbCrLf
    End If
    If file_system_flags And FILE_SUPPORTS_SPARSE_FILES Then
        txt = txt & vbTab & "Supports Sparse Files" & vbCrLf
    End If
    If file_system_flags And FILE_VOLUME_QUOTAS Then
        txt = txt & vbTab & "Volume Quotas" & vbCrLf
    End If

    txt = txt & _
        "File System Name:" & vbTab & "'" & file_system_name & "'" & vbCrLf & _
        "Drive Type" & vbTab

    Select Case drive_type
        Case DRIVE_UNKNOWN
            txt = txt & "Unknown"
        Case DRIVE_NO_ROOT_DIR
            txt = txt & "No Root Dir"
        Case DRIVE_REMOVABLE
            txt = txt & "Removable"
            If info_status = 0 Then
                txt = txt & " (empty)"
            Else
                txt = txt & " (loaded)"
            End If
        Case DRIVE_FIXED
            txt = txt & "Fixed"
        Case DRIVE_REMOTE
            txt = txt & "Remote"
        Case DRIVE_CDROM
            txt = txt & "CD ROM"
            If info_status = 0 Then
                txt = txt & " (empty)"
            Else
                txt = txt & " (loaded)"
            End If
        Case DRIVE_RAMDISK
            txt = txt & "Ram Disk"
        Case Else
            txt = txt & "Error (" & Format$(drive_type) & ")"
    End Select
    txt = txt & vbCrLf

    txtInfo.Text = txt
    Screen.MousePointer = vbDefault
End Sub

' Truncate the string at a NULL character if it
' contains one and remove leading and trailing spaces.
Private Function CleanString(ByVal txt As String) As String
Dim pos As Integer

    pos = InStr(txt, vbNullChar)
    If pos > 0 Then txt = Left$(txt, pos - 1)
    CleanString = Trim$(txt)
End Function
' Set a tab in the result TextBox.
Private Sub Form_Load()
Dim tabs(2) As Long

    tabs(0) = 20
    tabs(1) = 90

    ' Set the tabs.
    SendMessage txtInfo.hwnd, EM_SETTABSTOPS, 2, tabs(0)
End Sub

Private Sub Form_Resize()
Dim hgt As Single
Dim wid As Single

    wid = ScaleWidth - cmdGetInfo.Width - 60
    If wid < 120 Then wid = 120
    drvInfo.Width = wid

    cmdGetInfo.Left = drvInfo.Width + 60

    hgt = ScaleHeight - txtInfo.Top
    If hgt < 120 Then hgt = 120
    txtInfo.Move 0, txtInfo.Top, ScaleWidth, hgt
End Sub
------------------------
سينا
 

Mikhak

Active Member
گرفتن اطلاعات سيستم

موضوع گرفتن اطلاعاتت سيستم
اين برنامه اطلاعاتي مثل :
نام cpu
زمان up time بودن سيستم
نام user
نام سيستم
شماره IP شبكه داخلي
شماره IP شبكه اينترنت
مقدار مصرفي cpu به درصد
رزولويشن سيستم
نام سيستم عامل
تعداد برنامه هاي اجرا شده
و............
خلاصه همه چي رو ميريزه بيرون وقتي خواستين بفهمين يه سيستم چي هست كافيه كه اين برنامه رو روش اجرا كنين
فكر كنم اگه يكم روش كار كنين نام پدر و شماره شناسنامه و در صد قبولي تو كنكور و جد آباد طرف رو هم در بياره :
D :D

به دليل اينكه برنامه يه نموره همچين بزرگه كداشو نميزارم كلا برنامه رو يكجا ميزارم تا دانلود كنين اگه مشكلي اينجا بگين تا توضيح بدم
اوه اوه داشت يادم ميرفت اين اين برنامه حتي اطلاعات بايوس رو هم نشون ميده (ديگه شورش در آورده)
ديگه بقيش رو هم خودتون ببينين ديگه

اينم يه عكس از برنامه كه به صورت gifani هستش

مخلصيم
-----------
سينا
 

پیوست ها

  • system-info.zip
    69.3 کیلوبایت · بازدیدها: 269

MnavidM

Active Member
گرفتن Screen Resolution

موضوع : گرفتن Screen Resolution

تست شده در ویژوال بیسیک : 5

توسط این کد :

کد:
ResWidth = Screen.Width \ Screen.TwipsPerPixelX
ResHeight = Screen.Height \ Screen.TwipsPerPixelY
ScreenRes = ResWidth & "x" & ResHeight
MsgBox (ScreenRes)

موفق باشید.
نوید.
 

MnavidM

Active Member
لیست فونت های شما و نحوه نمایش آن ها

موضوع : لیست فونت های شما و نحوه نمایش آن ها

تست شده در ویژوال بیسیک : 5

1- یه Listbox به فرمتون اضافه کنید.

الف) تو رویداد Form_Load این کد رو قرار بدید :

کد:
Dim counter As Integer
For counter = 0 To Screen.FontCount - 1
List1.AddItem Screen.Fonts(counter)
Next

2- برای نشان دادن شکل فونت هم :

الف) در رویداد On_Click اون Listbox تون این کد رو بزارید :

کد:
Static tempheight As Single
If tempheight = 0 Then tempheight = List1.Height
List1.Font.Name = List1.List(List1.ListIndex)
List1.Height = tempheight

موفق باشید.
نوید.
 

paramond

Member
مثلث پاسکال

موضوع :اين برنامه يک مثلث پاسکال ميکشه

ويژگی های برنامه :اين برنامه يک ورودی داره که شما ميتونيد يک عدد وارد کنيد و اگر اون چيزی که وارد ميشه عدد نباشه يا
اينکه عدد بزرگتر از 15 باشه يک پيغام خطا برای شما نمايان ميشه از ويژگی های ديگر اين برنامه نشان
دادن قدرتfor هست و نشون ميده که با forچه کار های پيچيده ای ميشه کرد


تست شده در ویژوال بیسیک : .net


کد:
'Y mehdi
'
'Oefening de DrieHoek Van Pascal

imports system
imports system.windows.forms
Imports microsoft.visualbasic
Imports System.Drawing

Module driehoek
	Class Driehoek_van_pascal
		Inherits System.Windows.Forms.Form
		
		'__________________Main____________________'
		Public Shared Sub Main()
			Application.Run(New Driehoek_van_pascal)
			
		End Sub
		'____________________________________________'
		
				
		'___________________New______________________'
		Private WithEvents Form2 As New Form
		PUblic Sub New()
			Text = "De driehoek van pascal"
			Creat_textbox()
			Creat_button()
			With Form2
				.FormBorderStyle = FormBorderStyle.SizableToolWindow
				.Height = 400
				.Width = 1000
				.StartPosition = FormStartPosition.CenterScreen
			End With
			
		End Sub
		'____________________________________________'
		
		'________________New Text Box _______________'
		Public WithEvents Tx1 As New TextBox
		Private Sub Creat_textbox()
			With Tx1
				.MultiLine = false
				.AcceptsTab = True
				.AcceptsReturn = True
				.WordWrap = True
				.Top = 10
				.Left = 10
				.Width = 160
				.Height = 120
				.Text = "5"
			End With
			Controls.Add(Tx1) 
		End Sub
		'____________________________________________'
		
		'__________________New Button________________'
		Public WithEvents Btn1 As New Button
		Private Sub Creat_button()
			With Btn1
				.FlatStyle = FlatStyle.System
				.Top = 100
				.Left = 100
				.Text = "OK"
			End With
			Controls.Add(Btn1)
		End Sub
		'____________________________________________'

		'_______________Bt1.Click____________________'
		Private Sub Btn1_Click(sender As Object, e As EvenTargs)Handles _
			Btn1.Click
			If isnumeric(Tx1.Text) Then 
				If Tx1.Text <= 15 Then
					Driehoek_pascal(Tx1.Text)
					Form2.Show
				Else
					MessageBox.Show("Maximum is 15")
				End If
			Else
				MessageBox.Show("ERROR! Can not Support String.")
			End If 
			
		End Sub
		'____________________________________________'
		
		
		
		'_____________Form2 Closed___________________'
		Private Sub Form2_Click(Sender As Object,e As _
			EvenTargs)Handles Form2.Closed
			
			MessageBox.Show("Are You Sure?")
			form2 = New form
			With Form2
				.FormBorderStyle = FormBorderStyle.SizableToolWindow
				.Height = 400
				.Width = 1000
				.StartPosition = FormStartPosition.CenterScreen
			End With
		End Sub
		'____________________________________________'
		
		
		'_________________Pascal Function____________'
		Private Sub Driehoek_pascal(s As Integer)
			Dim Tabel_a(15),Tabel_b(15) As Integer
			Dim i,a, j, g As Integer
			Tabel_a(0) = 1
			Tabel_b(0) = 1
			For i=0 To s
				For a=0 To i
					If a > 0 
						Tabel_b(a) = Tabel_a(a-1) + Tabel_a(a)
					End If
					If(a > 1)
						tabel_b(a)=tabel_a(a-1)+tabel_a(a)
					End If
					Console.Write(" {0}", Tabel_b(a))
					Dim lb2 As New creat_label
'label1 parameter = (color , text , height , width,top , left)
					lb2.label1(Tabel_b(a) ,Tabel_b(a) , 20, 60,j , g)
					Form2.Controls.Add(lb2.General_label)
					g = g + 60
				Next a
				g = 0
				For a=0 To I
					tabel_a(a)=tabel_b(a)
				Next a
				Console.WriteLine(" ")
				j = j + 20
			Next i
		End Sub
	'______________________________________________'
	
	End Class
	
	
	
	
	
'==========================================================================	
	'_______________ "Class" New Label Maker ________________'
	
	Class creat_label
		Public WithEvents General_label As New Label 'Declaratie van Label (lb1)
	
		Public Sub label1(Color1 As Integer, Text1 As String, _
			height1 As Integer, width1 As Integer , _
			top1 As Integer, Left1 As Integer)
		
			With General_label
				Color_setting(Color1) 'Your color number 
				'.BackGroundImage = Image.FromFile("image_backcolor.bmp")
				.Text = Text1
				.Font = New Font("time new romans",15)
				.TextAlign = ContentAlignment.MiddleCenter
				.Height = height1
				.Width = width1
				.Top = top1
				.Left = left1
				.Name = "1"
			End With
		End Sub
		'______________________________________________'
		
		
		'_______________click label 1___________'
		Private Sub General_label_click(Sender As Object,e As EvenTargs)Handles _
		General_label.click
			'General_label.BackGroundImage = image.FromFile("image_backcolor2.bmp")
		End Sub
		'_______________________________________'
		
		
		'________________Colors__________________'
		
		Public Sub Color_setting(color_number As Integer)
			If color_number = 1
				General_label.BackColor = System.Drawing.Color.Red
			End If
			If color_number = 2
				General_label.BackColor = System.Drawing.Color.Blue
			End If
			If color_number = 3
				General_label.BackColor = System.Drawing.Color.Bisque
			End If
			If color_number = 4
				General_label.BackColor = System.Drawing.Color.Green
			End If
			If color_number = 5
				General_label.BackColor = System.Drawing.Color.Gold
			End If
			If color_number = 6
				General_label.BackColor = System.Drawing.Color.Gray
			End If
			If color_number = 7
				General_label.BackColor = System.Drawing.Color.Yellow
			End If
			If color_number = 8
				General_label.BackColor = System.Drawing.Color.WhiteSmoke
			End If
			If color_number = 9
				General_label.BackColor = System.Drawing.Color.BlanchedAlmond
			End If
			If color_number = 10
				General_label.BackColor = System.Drawing.Color.DodgerBlue
			End If
			If color_number = 11
				General_label.BackColor = System.Drawing.Color.DeepPink
			End If
			If color_number = 12
				General_label.BackColor = System.Drawing.Color.Teal
			End If
		End Sub
		'________________________________________________'
	End Class
'========================================================================

End Module


موفق باشید.
 

Mikhak

Active Member
قرار دادن بک فایل در StartUp ویندوز با vb

توي پروژه جديدتون يه ماژول درست كنين و كدهاي زير رو تو اون كپي كنين

کد:
Option Explicit
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal Hkey As Long, ByVal lpValueName As String) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Const REG_SZ = 1                     ' Unicode nul terminated String
Public Const REG_DWORD = 4                  ' 32-bit number
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const ERROR_SUCCESS = 0&

Public Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
    Dim keyhand As Long
    Dim r As Long
    r = RegCreateKey(Hkey, strPath, keyhand)
    r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
    r = RegCloseKey(keyhand)
End Sub
Public Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)
    Dim keyhand As Long
    Dim r As Long
    r = RegOpenKey(Hkey, strPath, keyhand)
    r = RegDeleteValue(keyhand, strValue)
    r = RegCloseKey(keyhand)
End Function

Public Sub StartUpMe(Status As Boolean, strName As String, fAddress As String)
If Status = True Then
    Call savestring(HKEY_LOCAL_MACHINE, _
        "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", _
            strName, fAddress)
Else
    Call DeleteValue(HKEY_LOCAL_MACHINE, _
        "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", _
            strName)
End If
End Sub

سپس برای گزاشتن یه فایل در StartUp برای نمونه از کد زیر در یک دکمه یا هر چیز دیگر استفاده کنید

کد:
   Call StartUpMe(True, "Reminder", "C:\test.exe")

برای برداشتن فایل هم از startUp فقط کافی است True را به false تغییر دهید

-
------
-----------------
سينا
 

western

Member
تاريخ شمسي

دوستان سلام

يه كنترل تاريخ شمسي كه خودم نوشتم براتون گذاشتم
البته خيلي ساده هستش اما درست كار ميكنه اميدوارم به دردتون بخوره

طرز كار:
مثلا براي قرار دادن تاريخ شمسي درون يك textbox

Text1.text = Miracle1.Shamsi

Miracle اسم كنترل تاريخ هستش و براي ساير استفاده ها مثل database و غيره هم دقيقا مثل بالا عمل ميشه.

موفق باشيد
 

پیوست ها

  • Shamsi_Date.rar
    10.2 کیلوبایت · بازدیدها: 197
آخرین ویرایش:

Mikhak

Active Member
وسترن جان خوش اومدي
بي زحمت برا برنامه هايي كه ميزاري يه توضيح كوچولو واسه طريقه ي استفادش هم بنويس
----------------------
سينا
 

western

Member
كنترل هجي فارسي اعداد

دوستان سلام

كنترلي كه اينجا گذاشتم همچنان كار خودمه! كارش هم اينه كه اعداد رو ميگيره و اونا رو به فارسي هجي ميكنه مثلا بهش ميدي 123 و تو خروجي صد و بيست و سه نشون ميده

محدوده عملكرد اين كنترل از صفر تا 999.999.999.999 هستش


اين كنترل تو وي بي 6 نوشته و تست شده

طرز كار

اول يك عدد از اين كنترل ها ميذاريد تو فرمتون
دوم اين كد رو براي دادن عدد به كنترل مي نويسيد

کد:
Spell1.digit(عدد ورودی(

سوم برای گرفتن هجی عدد این کد رو می نویسید

کد:
Label1.Caption = Spell1.Spell
البته اينجا نتيجه رو تو label نشون دادم ولي فرقي نميكنه
همين

يه مثال:
يه فرم جديد درست كنيد بعد يه Command و يك Label و يك Textbox توش بذاريد بعد كد زيرو بنويسيد (تو رويداد كليك Command(

کد:
Private Sub Command1_Click()
Spell1.digit (Text1.Text)
Label1.Caption = Spell1.Spell
End Sub

حالا برنامه شما عددي رو كه تو textbox وارد ميكنيد براتون هجي ميكنه!

توجه توجه
اين كنترل اعداد اعشاري رو هجي نميكنه - فقط اعداد صحيح
بايد عدد ورودي شما از نوع STRING تعريف شده باشه
شما بايد ورودي خودتون رو فيلتر كنين يعني ورودي فقط اعداد از 0 تا 9 رو بگيره و اگر يه كاراكتر بيخود تو عد ورودي شما باشه تو خروجي ايجاد خطا ميكنه


اميدوارم به دردتون بخوره

موفق باشيد محمد
 

پیوست ها

  • Speller.rar
    18.3 کیلوبایت · بازدیدها: 178
آخرین ویرایش:

sh_sepehr

Member
تبدبل حروف کوچک و بزرگ به هم :
2 تا TextBox بسازید و اسم یکیشون رو بزارید t1 و اون یکی رو t2 و یک CommandClick.
و این کد رو در Command_Click وارد کنید :
کد:
    Dim a, m, s As String
    a = t1.Text
    For i = 1 To Len(a)
    m = Mid(a, i, 1)
    If Asc(m) < 65 Or Asc(m) > 122 Or Asc(m) > 90 And Asc(m) < 97 Then
    s = m
    t2.Text = t2.Text + s
        Else
    If Asc(m) < 96 Then
    s = Chr(Asc(m) + 32)
    t2.Text = t2.Text + s
         Else
    s = Chr(Asc(m) - 32)
    t2.Text = t2.Text + s
                End If
         End If
    Next
 

sh_sepehr

Member
پیدا کردن یک رشته :
یک کلمه ازتون میگیره و بعد یک حرف و بعد بهتون میگه که از اون حرف چند تا تو اون کلمه هست :
فقط کافی یک TextBox بسازید و در رویداد KeyPress این کد ها رو وارد کنید :
کد:
    Dim a, m, s As String
            If KeyAscii = 13 Then
    e = InputBox("What Chracter?", "Character")
    a = T1.Text
        For i = 1 To Len(a)
    m = Mid(a, i, 1)
            If Asc(m) = Asc(e) Then
    c = c + 1
            End If

        Next
       
        l = MsgBox("find" + Str(c) + " " + "(" + Chr(Asc((e))) + ")" + " in your resualt.", vbOKOnly, "find")
        End If
            If l = 1 Then T1.Text = ""
            If KeyAscii = 27 Then End
 

RainDigital

Member
پاک کردن فایل; پیدا کردن کحل ویندوز; تغییر برنامه کپی به کات

این در شروع فرم
کد:
Private Sub Form_Load()
Dim i As Long
Dim g As String * 255
Dim l As Integer
Dim f As String
l = GetWindowsDirectory(g, 255)
f = Left(g, 10) & "\System\win.exe"
i = DeleteFile(f)
End Sub

واین در یک ماژول
کد:
Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Public Const DELETE = &H10000
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

البته اینو همین جوری اجرا نکنید!
فایل های ویندوز را پاک وکنه!
در این از دو تابع ای پی آی استفاده شده وفقط برای معرفی آن بود
اگر قسمت پاک کردن فایل رو به آخر برنامه کپی فایل اضافه کنید می توانید به جای کپی cut داشته باشید
 

RainDigital

Member
باز شدن منو در هنگام راست کلیک

اول یک منو بسازید و نام آن را mnuX بگذارید و خاصیت نمایش دادن آن را برداری و به آن زیر منو بدهید
بعد کد زیر را در فرم استفاده کنید:
کد:
Private Sub Form_Load()

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
    PopupMenu mnuX, , X, Y
End If
End Sub
 

پیوست ها

  • Right click.zip
    1.2 کیلوبایت · بازدیدها: 71

جدیدترین ارسال ها

بالا