چند سورس برنامه در ویژوال بیسیک

سورس تبدیل مبنا از دو به مبنای 10

Private sub command 1_click()
N = val (text1.text)
D = 0 P = 0
While n<>0
M = n mod 10
D= d+ m*2^p
P = p +1
N = n\10
Wend
Label1.caption = d
End sub

Private Sub Command1_Click()
Dim pri As Boolean
i = 2
While i <= 100
j = 2
pri = True
While j < SQR( i ) And pri = True
If i Mod j = 0 Then pri = False
j = j + 1
Wend
If pri = True Then Print i
i = i + 1
Wend
End Sub

Private Sub omid_Click()
Dim x As Integer
x = Text1.Text
Dim y As Integer
Dim a, b, c As Integer
a = Int(x / 100)
b = Int(x / 10) - 10 * a
c = x Mod 10
y = Val(c * 100 + b * 10 + a)
Print y
End Sub

با اين كد مي‌توانيد تصوير پس زمينه ويندوز خود را از طريق ويژوال بيسيك عوض نماييد

ابتدا تعاريف زير را در يك ماژول انجام دهيد

کد:

---


'Module (Declaration of Api Functions)

Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

'constants

Public Const SPIF_SENDWININICHANGE = &H2
Public Const SPIF_UPDATEINIFILE = &H1
Public Const SPI_SETDESKWALLPAPER = 20

---

سپس كد زير را براي عوض كردن تصوير اجرا نماييد.

کد:

---

---

کد:

---

'Form Code

Private Sub cmdChangeWallPaper_Click()
Dim ret As Long
ret = SystemParametersInfo(SPIF_SETDESKWALLPAPER, 0&, "c:\windows\bubble.bmp", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub

Private Sub cmdClearWallpaper_Click()
ret = SystemParametersInfo(SPIF_SETDESKWALLPAPER, 0&, "(None)", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub

---

با استفاده از اين كد مي‌توانيد كامپيوتر را خاموش نماييد.
ابتدا بايد كد زير را در يك ماژول وارد نماييد

کد:

---



Private Const EWX_SHUTDOWN As Long = 1
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long

---

سپس كد زير را وارد كنيد تا كامپيوتر خاموش شود.

کد:

---

(lngResult = ExitWindowsEx(EWX_SHUTDOWN, 0&

---

قبل از اجرا یه لیست باکس هم درست کنيد

کد:

---

Private Sub Command1_Click()
i = InputBox("")
For n = 1 To i
For j = n To 1 Step -1
If Not (n / j Like "*.*") Then
p = p + 1
If p > 2 Then GoTo 1
End If
Next
1:
If p <= 2 Then List1.AddItem n
p = 0
Next
End Sub

---

قبل از اجرا یه لیست باکس هم درست کنيد

کد:

---

Private Sub Command1_Click()
i = InputBox("")
For n = 1 To i
For j = n To 1 Step -1
If Not (n / j Like "*.*") Then
p = p + 1
If p > 2 Then GoTo 1
End If
Next
1:
If p <= 2 Then List1.AddItem n
p = 0
Next
End Sub

---

کد:

---

Private Sub Command1_Click()
m=val(label1.caption)

f=1

for i=1 to m

f=f * i

Next

label1.caption=f

End Sub

---

معكوس كردن متن( در ‌vb شما ميتونيد با استفاده از تابع StrReverse () يك متن رو معكوس كنيد) اين هم تابع كاملي براي معكوس كردن متن هستش

کد:

---

Private Sub Command1_Click()

Dim a as string

Dim b as string

Dim c as string

b=len(text1.text)

for c=b to 1 step -1

a=mid(text1.text,c,c1)

Text2.text=text2.text + a

Next c

End Sub

---

به دست آوردن ب.م.م دو عدد

کد:

---

Private function bmm( x as interger , y as integer) as integer

dim min, max ,i as integer

if (x>y) then

min=y

max=x

i=min

Do while ( y mod i <> 0 or x mod i <> 0)

i=i-1

loop

bmm=i

end if

if (x<y) then

min=x

max=y

i=min

Do while ( y mod i <> 0 or x mod i <> 0)

i=i-1

loop

bmm=i

else

bmm=x

end if

End Function

---

به دست آوردن ب.م.م دو عدد

کد:

---

Private function bmm( x as interger , y as integer) as integer

dim min, max ,i as integer

if (x>y) then

min=y

max=x

i=min

Do while ( y mod i <> 0 or x mod i <> 0)

i=i-1

loop

bmm=i

end if

if (x<y) then

min=x

max=y

i=min

Do while ( y mod i <> 0 or x mod i <> 0)

i=i-1

loop

bmm=i

else

bmm=x

end if

End Function

---

دوست عزیز
سورس های خودتون رو اینجا بزارید.

کد:

---

http://forum.p30world.com/showthread.php?t=326408

---

دست طلا راحت شدم