VİSUAL BASİC DOWNLOAD BÖLÜMÜ

VİSUAL BASİC İNDİR



HAZIR VİSUAL BASİCC KODLARI İNDİR

Visual Basic 6.0 ile yapilan bazi programlarin Windows isletim sisteminde çalismasi için bazi dosyalara ihtiyaci vardir. Bu program iste bu programlarin çalismasi için gerekli olan dosyalari içerir.
İNDİRMEK İÇİN TIKLA


İNDİR

visual basicc video anlatım

visual basicc oyun yapımı



animasyon

Visual Basicte Basit bir Telefon Programı visual basicc

Numara kaydedebilen telefon programı

'Bu Program bekir demir tarafından genel amaçlı olarak yazılıp kopyalanması ve dağıtılması yasak degildir
Option Explicit

DefInt A-Z

Dim CancelFlag

Private Sub CancelButton_Click()
CancelFlag = True
CancelButton.Enabled = False
End Sub

Private Sub Dial(N$)
Dim DialString$, FromModem$, dummy

DialString$ = "ATDT" + N$ + ";" + vbCr

' Bağlantı Port ayarları
MSComm1.CommPort = 3
MSComm1.Settings = "9600,N,8,1"

' Bağlantı portunu aç
On Error Resume Next
MSComm1.PortOpen = True
If Err Then
Exit Sub
End If

MSComm1.InBufferCount = 0

'Numarayı çevir
MSComm1.Output = DialString$

' modeme geri dönmek için tamamı bekle
Do
dummy = DoEvents()
If MSComm1.InBufferCount Then
FromModem$ = FromModem$ + MSComm1.Input
' Tamam'ı Kontrol et
If InStr(FromModem$, "OK") Then
'Kullanıcı telefonu kaldırırsa
Beep
MsgBox "Lütfen Ahizeyi Kaldırıp ENTER a Basın"
Exit Do
End If
End If

' Kullanıcı iptali seçerse
If CancelFlag Then
CancelFlag = False
Exit Do
End If
Loop

' Modemle bağlantıyı kes
MSComm1.Output = "ATH" + vbCr

' Portu kapat
MSComm1.PortOpen = False
End Sub

Private Sub Command1_Click(Index As Integer)
Durum.Text = Durum.Text + Command1(Index).Caption
End Sub

Private Sub Command2_Click()
Text1.Visible = False
Text2.Visible = False
Command2.Visible = False
End Sub

Private Sub Command3_Click()
Durum.Text = Num.Caption
Command4.Visible = True
End Sub

Private Sub Command4_Click()
Data1.Refresh
Command4.Visible = False
Command3.Visible = True

End Sub

Private Sub Data1_Validate(Action As Integer, Save As Integer)
On Error Resume Next
End Sub

Private Sub DialButton_Click()
Dim N$, T$

DialButton.Enabled = False
QuitButton.Enabled = False
CancelButton.Enabled = True
' Çevirmek için gerekli numara
N$ = Durum.Text

T$ = Durum
Durum = "Çevriliyor - " + N$

' Çevrilecek Telefon Numarasını Seç
Dial N$

DialButton.Enabled = True
QuitButton.Enabled = True
CancelButton.Enabled = False

Durum = T$
End Sub

Private Sub Form_Load()
MSComm1.InputLen = 0

End Sub

Private Sub Kay_Click()
Data1.Recordset.AddNew
Text2.Visible = True
Command2.Visible = True
Text1.Visible = True
End Sub

Private Sub Label1_DblClick()
Data1.Refresh
End Sub

Private Sub Label4_Click()

End Sub

Private Sub QuitButton_Click()
End
End Sub

Private Sub Sil_Click()
On Error Resume Next

şekilli pencere visual basicc

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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Sub Form_Load()
Dim hr&, dl&
Dim usew&, useh&
usew& = Me.Width / Screen.TwipsPerPixelX
useh& = Me.Height / Screen.TwipsPerPixelY
' Olusturuluyor...
hr& = CreateEllipticRgn(-150, -210, usew, useh) 'Bu sayilari degistirerek pencere ile oynayabilirsiniz..
' Gosteriliyor...
dl& = SetWindowRgn(Me.hWnd, hr, True)
End Sub

sayıyı yazıya çeviren program visual basicc

Sayın Bülent Yenilmez sayıyı yazıya çeviren bir fonksiyon yollamış, kendisine teşekkür ediyorum. Ayrıca sorununada şöyle bir ipucu vereyim ingilizcede 11 ve 19 arası sayıların sesletimleri türkçede olduğu gibi 1 'on' ve 'bir' kelimelerinin birleşmeleri ile meydana gelmez. yani 11 için 'eleven' kelimesi ingilizce 10 'ten' ve 1 'one' kelimelerinden oluşmaz. Bu durumda bu sayılar için fonksiyon içinde özel bir bölüm gerekiyor.
Tüm kod aşağıdadır


'Bu fonksiyon cok güzel bir şekilde çalışıyor. Dileyen arkadaşlar kullanabilir.
'Bir isteğim olacak. Bu fonksiyondan yola çıkarak aynı şekilde ingilizcesini yazdırmak istediğimde
'11 den 19 a kadar olan sayılarda "eleven" yerine "tenone" çıkıyor. Bu sorunu çözebilen olursa
'lütfen bana haber versin... Şimdiden Teşekkürler.

Dim b$(9)
Dim y$(9)
Dim m$(4)
Dim v(15)
Dim c(3)
Private Sub Form_Load()
Text1.Text = Yaziyla$(15000)
End Sub

Function Yaziyla$(sayi)

b$(0) = ""
b$(1) = "Bir"
b$(2) = "İki"
b$(3) = "Üç"
b$(4) = "Dört"
b$(5) = "Beş"
b$(6) = "Altı"
b$(7) = "Yedi"
b$(8) = "Sekiz"
b$(9) = "Dokuz"

y$(0) = ""
y$(1) = "On"
y$(2) = "Yirmi"
y$(3) = "Otuz"
y$(4) = "Kırk"
y$(5) = "Elli"
y$(6) = "Altmış"
y$(7) = "Yetmiş"
y$(8) = "Seksen"
y$(9) = "Doksan"

m$(0) = "Trilyon"
m$(1) = "Milyar"
m$(2) = "Milyon"
m$(3) = "Bin"
m$(4) = ""

a$ = Str(sayi)
If Left$(a$, 1) = " " Then pozitif = 1 Else pozitif = 0
a$ = Right$(a$, Len(a$) - 1)
For x = 1 To Len(a$)
If (Asc(Mid$(a$, x, 1)) > Asc("9")) Or (Asc(Mid$(a$, x, 1)) < Asc("0")) Then GoTo hata
Next x
If Len(a$) > 15 Then GoTo hata
a$ = String(15 - Len(a$), "0") + a$
For x = 1 To 15
v(x) = Val(Mid$(a$, x, 1))
Next x

s$ = ""
For x = 0 To 4
c(1) = v((x * 3) + 1)
c(2) = v((x * 3) + 2)
c(3) = v((x * 3) + 3)
If c(1) = 0 Then
e$ = ""
ElseIf c(1) = 1 Then
e$ = "Yüz"
Else
e$ = b$(c(1)) + "Yüz"
End If
e$ = e$ + y$(c(2)) + b$(c(3))
If e$ <> "" Then e$ = e$ + m$(x)
If (x = 3) And (e$ = "BirBin") Then e$ = "Bin"
s$ = s$ + e$
Next x

If s$ = "" Then s$ = "Sıfır"
If pozitif = 0 Then s$ = "Eksi" + s$
Yaziyla$ = s$
GoTo tamam
hata: Yaziyla$ = "Hata"
tamam:
End Function

Sayısal Loto visual basicc kodu sayısal loto programı

Sayısal Loto
--------------------------------------------------------------------------------
Güzel bir numara sallama örneği; önce üç tane commmand buton koy sonra 6 Text box ve kodu kopyala


Private Sub Command1_Click()
Dim NumberList(5) As Integer
' Numaraların her zaman farklı olması için bunu yazıyoruz
Randomize Timer
Text1.Text = Int(Rnd * 49) + 1
Text2.Text = Int(Rnd * 49) + 1
Text3.Text = Int(Rnd * 49) + 1
Text4.Text = Int(Rnd * 49) + 1
Text5.Text = Int(Rnd * 49) + 1
Text6.Text = Int(Rnd * 49) + 1
'Sallanan numaraların aynı olma ihtimali çok yüksektir bundan dolyı bu kodları ekliyoruz
If Text1.Text = Text2.Text Or Text1.Text = Text3.Text Or Text1.Text = Text4.Text Or Text1.Text = Text5.Text Or Text1.Text = Text6.Text Then
Text1.Text = Int(Rnd * 49) + 1
End If
If Text2.Text = Text1.Text Or Text2.Text = Text3.Text Or Text2.Text = Text4.Text Or Text2.Text = Text5.Text Or Text2.Text = Text6.Text Then
Text2.Text = Int(Rnd * 49) + 1
End If
If Text3.Text = Text1.Text Or Text3.Text = Text2.Text Or Text3.Text = Text4.Text Or Text3.Text = Text5.Text Or Text3.Text = Text6.Text Then
Text3.Text = Int(Rnd * 49) + 1
End If
If Text4.Text = Text1.Text Or Text4.Text = Text2.Text Or Text4.Text = Text3.Text Or Text4.Text = Text5.Text Or Text4.Text = Text6.Text Then
Text4.Text = Int(Rnd * 49) + 1
End If
If Text5.Text = Text1.Text Or Text5.Text = Text2.Text Or Text5.Text = Text3.Text Or Text5.Text = Text4.Text Or Text5.Text = Text6.Text Then
Text5.Text = Int(Rnd * 49) + 1
End If
If Text6.Text = Text1.Text Or Text6.Text = Text2.Text Or Text6.Text = Text3.Text Or Text6.Text = Text4.Text Or Text6.Text = Text5.Text Then
Text6.Text = Int(Rnd * 49) + 1
End If
'Bu kodlar text boxlardaki değerlerin küçükten büyüğe sıralanmasını sağlar
NumberList(0) = CInt(Text1.Text)
NumberList(1) = CInt(Text2.Text)
NumberList(2) = CInt(Text3.Text)
NumberList(3) = CInt(Text4.Text)
NumberList(4) = CInt(Text5.Text)
NumberList(5) = CInt(Text6.Text)
For j = 0 To 5
For i = 0 To 4
If NumberList(i) > NumberList(i + 1) Then
temp = NumberList(i)
NumberList(i) = NumberList(i + 1)
NumberList(i + 1) = temp
End If
Next i
Next j
Text1.Text = NumberList(0)
Text2.Text = NumberList(1)
Text3.Text = NumberList(2)
Text4.Text = NumberList(3)
Text5.Text = NumberList(4)
Text6.Text = NumberList(5)
End Sub

Private Sub Command2_Click()
mesaj = MsgBox("Bu Program Şükrü Sanioğlu tarafından yapılmıştır (C). 2003-2004 | SS-Yazılım |", 10, "Sayısal Loto 6/49 Programı Hakkında")
End Sub

Private Sub Command3_Click()
End
End Sub

ram ölçer visual basicc kod

Bir adet Timer ekleyin forma kopyalayın..

Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

Private Sub Form_load()
Timer1.Interval = 1000
End Sub

Private Sub Timer1_Timer()
Cls
Dim m As MEMORYSTATUS
GlobalMemoryStatus m
Print "Bellek Kullanımı %:", m.dwMemoryLoad
Print "Toplam RAM:", , m.dwTotalPhys / 1024 / 1024 & " MB"
Print "Boş RAM:", , m.dwAvailPhys / 1024 / 1024 & "MB"
End Sub

şifreli giriş visual basicc

İlk önce visual basic i açın.Form üzerine bi tane sifre adında textbox1 ve tamam adın da Command1 butonu eklleyin ve aşağıda ki kodu kopyalayın..


Private Sub tamam_Click()

if sifre.text="DAGARSLAN" then
msgbox "Şifre Doğru Giriş Onaylandı",8,"Giriş Tamam"
form2.show
form1.hide
else
msgbox "Şifreyi Bilemediniz!!!",6,"Byes"
end 'Programı Kapatıyozz
end sub

Download Programı visual basicc kod

Download Programı...
--------------------------------------------------------------------------------
Bu kodlar ile Inet kullanımı hakkında daha fazla bilginiz olacak...
Merhaba. Burada Inet (Internet Transfer Control) nesnesinin kullanımı hakkında kısa bilgiler yer almaktadır. Ayrıca örnek olarak da bir download programı yazdım ve kodlarını sizlerle paylaşıyorum.
İlk önce forma aşağıdaki resimde görüldüğü gibi iki textbox, bir commandbutton ve bir Inet nesnesi ekleyin.


Textboxların adını “Adres” ve “Kayıtadı”, commandbuttonun ise “Başla” olarak değiştirdikten sonra aşağıdaki kodları “Başla” isimli commandbuttonun click olayına yapıştırın. Daha sonra Inet nesnesinin Protocol özelliğini 2-icFTP değerini seçin. Hepsi bu…

'********©2003*********
'*****Volkan ESGEL*****
'***vesgel@mynet.com***
'**www.essoft.cjb.net**
'-----Bu kod tamamen eğitim amaçlıdır. Bu kod ile Inet nesnesinin kullanımını daha iyi öğrenebilirsiniz...-----
‘*************************
Private Sub Başla_Click()
Dim Mx() As Byte 'Mx() tanımlanıyor...
Me.Caption = "Dosya yükleniyor..." 'Formun başlğı değiştiriliyor...
Mx() = Inet1.OpenURL(Adres.Text, 1) 'Adres açılıyor...
Open App.Path & Kayıtadı.Text For Binary Access Write As #1 'Etkin dizine belirtilen isim ve uzantıda dosya oluşturuluyor...
Put #1, , Mx() 'Dosya kaydediliyor...
Close #1 ' #1 Kapatılıyor...
MsgBox ("Dosya yüklendi..." & vbCrLf & "adres=" & App.Path & Kayıtadı.Text) 'Sonuç olarak dosyanın yüklendiği dizin ve dosya adı mesaj olarak gönderiliyor...
End Sub
‘*************************
Artık program çalışmaya hazır. Adres kısmına (www.essoft.cjb.net/essoft.gif) gibi bir internet adresi ve Dosya Adı kısmına bilgisayarınıza dosyanın kaydedileceği ismi (“essoft.gif” gibi) girdikten sonra “İndir” tuşuna basın. Dosya indiriliyor… Dosya indirme işlemi bittiğinde ise dosyanın hdd’nizde kaydedildiği dizin vb. bilgiler veriliyor.

******Inet ( Internet Transfer Control ) Hakkında Bilgiler******

¦ Remote Port
İstemci ile bilgisayarın sunucu bilgisayara bağlantı sırasında kullanacağı port numarasını belirler. Bu bilgi verilmez ise varsayılan değerler işleme konur ve FTP için 21, http için 80 portu kullanılır.
¦ Protocol
Bağlantı sırasında kullanacağımız protokolü belirler. Bu gerçekten önemlidir. Her protokolün farklı kuralları vardır ve bağlandığımız sunucu ile aynı protokole bağımlı bir şekilde veri alışverişi sağlamazsak sistem zarar görecektir. Bir FTP sunucuya http ile bağlantı kurmaya çalışmamız hem istemci hem de sunucuya hata mesajlarıyla geri dönecektir ve bağlantı kurulamayacaktır. Bu nedenle ulaşmak istediğimiz veriye en uygun sunucuyu seçtikten sonra bu sunucunun kabul ettiği protokole uygun bir şekilde bağlantı isteğinde bulunmalıyız.
Inet nesnesi 3 farklı protokolü taban olarak kabul edebilir:
İcUnknown: bilinmeyen; icDefault: varsayılan; icFTP: FTP; icHTTP: http; icHTTPS: HTTPS.
¦ Request Time Out
Bağlantı isteği gönderildikten sonra istemci, sunucunun bağlantıyı kabul etmsini bekler, bir süre yanıt gelmezse beklemekten vazgeçip bağlantıyı keser. İşte bu süreyi requesttimeout ile belirliyoruz. Requesttimeout değeri saniye cinsinden yazılır ve sınırsız süre verilmek istendiğinde 0 değeri atanır.
Sunucu çok yoğun çalışıyorsa ve isteklere cevap vermede gecikiyorsa zaman aşımı süremizi yüksek tutmamız gerekir. Aksi takdirde henüz sunucuda bize sıra gelmeden bağlantı isteği iptal edilir ve asla bağlantı gerçekleşmez.
¦ OpenURL
Inet nesnemizin bağlanacağı sunucu ve ulaşacağı dosyayı bu komutla belirleyebiliriz. Bu komut .openURL(“adres”, “veri_tipi”) şeklinde kullanılır. Buradaki veri tipi değeri 0 veya 1 olabilir. Hiçbir değer verilmezse 0 kabul edilir. 0 değeri bize gelen verilerin string formatında olmasını sağlar. 1 değeri ise aynı verileri binary formatta ve byte dizisi halinde getirir. OpenURL komutunun daha gelişmiş olan alternatifleri de vardır.
¦ StillExecuting
Gelişmiş uygulamalarımızda sıkça kullandığımız komutlardan biri de stillexecuting komutudur. Bu aslında komut değil Boolean bir değerdir. Inet nesnemize herhangi bir komutu verip işlemesini sağladıktan sonra işlemin bitip bitmediğini stillexecuting ile öğrenebiliriz. Inet nesnesi aynı anda birden fazla işlem yapamayacağı için işlem yaptığı sırada başka bir işleme zorlanması hatalara neden olacaktır. Bu gibi durumlarda stillexecuting ile sistemin meşgul olup olmadığını kontrol ederek sıradaki komutları beklemeye alabiliriz. Stillexecuting değerinin True olması sistemin meşgul olduğunu, False olması ise işlemin tamamlandığını belirtir.
¦Execute
OpenURL metodu ile aynı işi görmesine rağmen daha gelişmiştir. Sunucu ile sürekli haberleşme sağlar ve sunucu ile dosyalama hizmetlerini başlatma yetkisine sahiptir.
¦ AccessType
Nesnemizin Internet veya Intranet bağlantısı sırasında kullanacağı bağlantı hizmetlerini belirlemek amacıyla kullanılır. Direkt bağlantı kurulacaksa bu değer boş bırakılabilir. Yine bu değere bağlı olarak Proxy server bağlantısı yapılacağı nesneye bildirilir ve daha sonra Proxy değeri verilerek hedef sunucuya ulaşılır.
¦ Proxy
Bu değer sadece AccessType değeri 2 olduğunda yani “Proxy kullan” emri verildiğinde devreye girer. IP adresi veya domainname değeri alabilir. Bu kullanılacak olan Proxy server adresidir ve hedef sunucuya ulaşmadan önce bu adrese bakılarak bir proxy’den çıkış yapılır.

Benden bu kadar… Download programı örneğini ve Inet kontrolünün kullanımı hakkında yeterli bilgiyi burada verdiğime inanıyorum. Eğer bu yazıyı yazarken atladığım veya yanlış yazdığım şeyler varsa bana mesaj atın. Bu programı daha da geliştirerek çok güçlü Download programları yazılabilir. Bu kodun daha da geliştirilmiş şeklini görmek istiyorum. Onun için sizden bu koddan yola çıkarak geliştirmiş olduğunuz kodları programlama.com’da veya vesgel@mynet.com ’da görmek beni çok sevirdirecek. Umarım öyle olur. Takıldığınız yerlerde bana mesaj atabilirsiniz. Umarım bu kodlar size Inet kullanımını daha iyi anlatacaktır.

API kullanarak bir diskete format atmak için visual basicc kod

API kullanarak bir diskete format atmak için aşağıdaki kodu kullanabilirsiniz.
Not: Bu kod harddiske format atabilir, bu nedenle dikkatli olmalısınız.

Önce, Bu kodu bir formun General Declarations bölümüne kopyalayın:


Private Declare Function SHFormatDrive Lib "shell32" _
(ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, _
ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias _
"GetDriveTypeA" (ByVal nDrive As String) As Long


Forma iki CommandButtons ekleyin:
Birincinin adı: "cmdFormatDrive"
İkincinin adı: "cmdDiskCopy"



Private Sub cmdFormatDrive_Click()
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg%
DriveLetter = UCase(Drive1.Drive)
DriveNumber = (Asc(DriveLetter) - 65) ' Change letter to Number:
A=0
DriveType = GetDriveType(DriveLetter)
If DriveType = 2 Then 'Floppies, etc
RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Else
RetFromMsg = MsgBox("This drive is NOT a
removeable" & vbCrLf & _
"drive! Format this drive?", 276,
"SHFormatDrive Example")
Select Case RetFromMsg
Case 6 'Yes
' UnComment to do it...
'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Case 7 'No
' Do nothing
End Select
End If
End Sub

Private Sub cmdDiskCopy_Click()
' DiskCopyRunDll takes two parameters- From and To
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg&
DriveLetter = UCase(Drive1.Drive)
DriveNumber = (Asc(DriveLetter) - 65)
DriveType = GetDriveType(DriveLetter)
If DriveType = 2 Then 'Floppies, etc
RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll
" _
& DriveNumber & "," & DriveNumber, 1) 'Notice
space after
Else ' Just in case 'DiskCopyRunDll
RetFromMsg = MsgBox("Only floppies can" & vbCrLf & _
"be diskcopied!", 64, "DiskCopy
Example")
End If
End Sub



Forma birde Drive1 adlı ListDrive ekleyin:



Private Sub Drive1_Change()
Dim DriveLetter$, DriveNumber&, DriveType&
DriveLetter = UCase(Drive1.Drive)
DriveNumber = (Asc(DriveLetter) - 65)
DriveType = GetDriveType(DriveLetter)
If DriveType <> 2 Then 'Floppies, etc
cmdDiskCopy.Enabled = False
Else
cmdDiskCopy.Enabled = True
End If
End Sub

Cok Basit Bir Animasyon Ornegi visual basicc

Cok Basit Bir Animasyon Ornegi
--------------------------------------------------------------------------------
Bu Kadar Basit'miydi Diyeceksiniz
'1-Araç çubuklarına sağ tuşla tıklayın

'2-Açılan menüden Components'i seçin

'3-Gelen pencereden internet controllers'i seçin

'4-Projeye ekleyin

'5-Oradanda formunuza ekleyin

'6-Forma eklediğiniz internet sayfası nesnesinin URL özelliğine herhangi bir hareketli gif resminin adresini ("")çift tırnak işareti kullanmadan tam olarak yazınız.

'7-Eğer buraya kadar doğru yapmışiseniz Projeyi çalıştırmadan Hareketli gif resmi aktif olacaktır.

'8-internet sayfası resminin tam üzerine 1 tane picturebox ekleyin

'7-internet sayfası nesnesine eklediğiniz hareketli animasyon resminin aynısını picturebox nesnesinin picture özelliğini kullanarak özellikler penceresinden ekleyin.

'8-resmin ilk hali picturebox nesnesinde belirecektir.

'9-İki tane commandbutton ekleyin

'10-Command1'in caption özelliğini Oynat yapın

'11-Command2'nin caption özelliğini durdur yapın

'12-internet sayfasının visible özelliğini false yapın

'13-Aşağıdaki kodları ilgili yordamlara yazın veya kopyala yapıştır metodunu uygulayın





Private Sub Command1_Click 'Oynat Butonu

internetControl.visible=True
Picture1.Visible=False

End Sub


Private Sub Command2_Click 'Oynat Butonu

internetControl.visible =False
Picture1.Visible=True

End Sub


'Hepsi Bu Kadar Kolay Gelsin

çarpan top visual basicc

Çarpan Top
--------------------------------------------------------------------------------
Bu Programla İstediğiniz top şeklini istediğiniz duvara çarptırıp geri gelebilir Çok eğlenceli bir programYapan Kadırga Lisesinden By.VolCanO Teşekkürler...

Option Explicit

Private Sub Command1_Click()
If Command1.Caption = "SToP" Then
Command1.Caption = "STaRT"
Timer1.Interval = 0
Timer2.Interval = 0
Timer3.Interval = 0
Timer4.Interval = 0
Else
Command1.Caption = "SToP"
Timer1.Interval = HScroll3.Value
Timer2.Interval = HScroll3.Value
Timer3.Interval = HScroll3.Value
Timer4.Interval = HScroll3.Value
End If
End Sub

Private Sub Command2_Click()
Command2.Visible = False
Label1.Visible = False
Label2.Visible = False
Label3.Visible = False
HScroll1.Visible = False
HScroll2.Visible = False
HScroll3.Visible = False
End Sub

Private Sub Form_Load()
Form1.Picture = LoadPicture()
Image1.Picture = LoadPicture()

End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim c
c = MsgBox("ÇıKMaK İçiN Menüyü KullaN..!", vbOKOnly + vbCritical, "VolCaNo SoFTwaRE")
If c = vbOK Then
Cancel = True
End If
End Sub

Private Sub HScroll1_Change()
Dim h
h = HScroll1.Value
End Sub

Private Sub HScroll2_Change()
Dim v
v = HScroll2.Value
End Sub

Private Sub HScroll3_Change()
Timer1.Interval = HScroll3.Value
Timer2.Interval = HScroll3.Value
Timer3.Interval = HScroll3.Value
Timer4.Interval = HScroll3.Value
End Sub

Private Sub MnArkaPlan_Click()
Form1.Enabled = False
Form3.Visible = True
End Sub

Private Sub MnÇıkış_Click()
Form1.Visible = False
Form5.Timer3.Enabled = False
Form5.Timer2.Enabled = True
Form5.Visible = True

End Sub

Private Sub MnHız_Click()
Command2.Visible = True
Label1.Visible = True
Label2.Visible = True
Label3.Visible = True
HScroll1.Visible = True
HScroll2.Visible = True
HScroll3.Visible = True
End Sub

Private Sub MnŞekil_Click()
Form1.Enabled = False
Form2.Visible = True
End Sub

Private Sub MnVolcanO_Click()
Form1.Visible = False
Form5.Timer3.Enabled = True
Form5.Timer2.Enabled = False
Form5.Visible = True
End Sub

Private Sub Timer1_Timer()
Dim h, v
h = HScroll1.Value
v = HScroll2.Value
Shape1.Left = Shape1.Left + h
Label4.Caption = Shape1.Left
Shape1.Top = Shape1.Top + v
Label5.Caption = Shape1.Top
If Shape1.Top >= 4080 Then
Timer1.Enabled = False
Timer2.Enabled = True
End If
If Shape1.Left >= 6360 Then
Timer1.Enabled = False
Timer2.Enabled = True
End If
If Shape1.Top <= 0 Then
Timer1.Enabled = False
Timer3.Enabled = True
End If
If Shape1.Left <= 0 Then
Timer1.Enabled = True

End If
End Sub
Private Sub Timer2_Timer()
Dim h, v
h = HScroll1.Value
v = HScroll2.Value
Shape1.Left = Shape1.Left + h
Label4.Caption = Shape1.Left
Shape1.Top = Shape1.Top - v
Label5.Caption = Shape1.Top
If Shape1.Left >= 6360 Then
Timer2.Enabled = False
Timer3.Enabled = True
End If
If Shape1.Top <= 0 Then
Timer2.Enabled = False
Timer3.Enabled = True
End If
If Shape1.Left <= 0 Then
Timer2.Enabled = False
Timer1.Enabled = True
End If
If Shape1.Top >= 4080 Then
Timer2.Enabled = True


End If
End Sub

Private Sub Timer3_Timer()
Dim h, v
h = HScroll1.Value
v = HScroll2.Value
Shape1.Left = Shape1.Left - h
Label4.Caption = Shape1.Left
Shape1.Top = Shape1.Top - v
Label5.Caption = Shape1.Top
If Shape1.Top <= 0 Then
Timer3.Enabled = False
Timer4.Enabled = True
End If
If Shape1.Left <= 0 Then
Timer3.Enabled = False
Timer4.Enabled = True
End If
If Shape1.Top >= 4080 Then
Timer3.Enabled = False
Timer2.Enabled = True
End If
If Shape1.Left >= 6360 Then
Timer3.Enabled = True

End If
End Sub

Private Sub Timer4_Timer()
Dim h, v
h = HScroll1.Value
v = HScroll2.Value
Shape1.Left = Shape1.Left - h
Label4.Caption = Shape1.Left
Shape1.Top = Shape1.Top + v
Label5.Caption = Shape1.Top
If Shape1.Left <= 0 Then
Timer4.Enabled = False
Timer1.Enabled = True
End If
If Shape1.Top >= 4080 Then
Timer4.Enabled = False
Timer1.Enabled = True
End If
If Shape1.Left >= 6360 Then
Timer4.Enabled = False
Timer3.Enabled = True
End If
If Shape1.Top <= 0 Then
Timer4.Enabled = True

End If
End Sub
Option Explicit

Private Sub Command1_Click()
Form1.Enabled = True
Form2.Visible = False

End Sub

Private Sub HScroll1_Change()
Form1.Shape1.BorderWidth = HScroll1.Value
Shape1.BorderWidth = HScroll1.Value
End Sub

Private Sub HScroll2_Change()
Form1.Shape1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
Text1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
Shape1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
End Sub

Private Sub HScroll3_Change()
Form1.Shape1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
Text1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
Shape1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
End Sub

Private Sub HScroll4_Change()
Form1.Shape1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
Text1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
Shape1.BackColor = RGB(HScroll2.Value, HScroll3.Value, HScroll4.Value)
End Sub

Private Sub HScroll5_Change()
Form1.Shape1.FillColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
Text2.BackColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
Shape1.FillColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
End Sub

Private Sub HScroll6_Change()
Form1.Shape1.FillColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
Text2.BackColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
Shape1.FillColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
End Sub

Private Sub HScroll7_Change()
Form1.Shape1.FillColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
Text2.BackColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
Shape1.FillColor = RGB(HScroll5.Value, HScroll6.Value, HScroll7.Value)
End Sub

Private Sub Option1_Click()
Form1.Shape1.Shape = 0
Shape1.Shape = 0
End Sub

Private Sub Option10_Click()
Label1.Visible = False
HScroll1.Visible = False
Form1.Shape1.BorderStyle = 3
Shape1.BorderStyle = 3
End Sub

Private Sub Option11_Click()
Label1.Visible = False
HScroll1.Visible = False
Form1.Shape1.BorderStyle = 4
Shape1.BorderStyle = 4
End Sub

Private Sub Option12_Click()
Label1.Visible = False
HScroll1.Visible = False
Form1.Shape1.BorderStyle = 5
Shape1.BorderStyle = 5
End Sub

Private Sub Option13_Click()
Label1.Visible = True
HScroll1.Visible = True
Form1.Shape1.BorderStyle = 6
Shape1.BorderStyle = 6
End Sub

Private Sub Option14_Click()
Form1.Shape1.FillStyle = 0
Shape1.FillStyle = 0
End Sub

Private Sub Option15_Click()
Form1.Shape1.FillStyle = 1
Shape1.FillStyle = 1
End Sub

Private Sub Option16_Click()
Form1.Shape1.FillStyle = 2
Shape1.FillStyle = 2
End Sub

Private Sub Option17_Click()
Form1.Shape1.FillStyle = 3
Shape1.FillStyle = 3
End Sub

Private Sub Option18_Click()
Form1.Shape1.FillStyle = 4
Shape1.FillStyle = 4
End Sub

Private Sub Option19_Click()
Form1.Shape1.FillStyle = 5
Shape1.FillStyle = 5
End Sub

Private Sub Option2_Click()
Form1.Shape1.Shape = 1
Shape1.Shape = 1
End Sub

Private Sub Option20_Click()
Form1.Shape1.FillStyle = 6
Shape1.FillStyle = 6
End Sub

Private Sub Option21_Click()
Form1.Shape1.FillStyle = 7
Shape1.FillStyle = 7
End Sub

Private Sub Option3_Click()
Form1.Shape1.Shape = 2
Shape1.Shape = 2
End Sub

Private Sub Option4_Click()
Form1.Shape1.Shape = 3
Shape1.Shape = 3
End Sub

Private Sub Option5_Click()
Form1.Shape1.Shape = 4
Shape1.Shape = 4
End Sub

Private Sub Option6_Click()
Form1.Shape1.Shape = 5
Shape1.Shape = 5
End Sub

Private Sub Option7_Click()
Label1.Visible = False
HScroll1.Visible = False
Form1.Shape1.BorderStyle = 0
Shape1.BorderStyle = 0
End Sub

Private Sub Option8_Click()
Label1.Visible = True
HScroll1.Visible = True
Form1.Shape1.BorderStyle = 1
Shape1.BorderStyle = 1
End Sub

Private Sub Option9_Click()
Label1.Visible = False
HScroll1.Visible = False
Form1.Shape1.BorderStyle = 2
Shape1.BorderStyle = 2
End Sub
Option Explicit

Private Sub Command1_Click()
Form1.Enabled = True
Form3.Visible = False
End Sub

Private Sub Command2_Click()
Form1.Image1.Picture = LoadPicture(Form3.File1.FileName)

End Sub

Private Sub Command3_Click()
Image1.Picture = LoadPicture()
Form1.Image1.Picture = LoadPicture()
End Sub

Private Sub Dir1_Change()
File1.Path = Dir1.Path
ChDir Dir1.Path
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
ChDrive Drive1.Drive
End Sub

Private Sub File1_Click()
Image1.Picture = LoadPicture(File1.FileName)
End Sub

Private Sub HScroll1_Change()
Form1.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Form3.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label1.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label2.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label3.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label4.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub HScroll2_Change()
Form1.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Form3.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label1.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label2.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label3.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label4.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub HScroll3_Change()
Form1.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Form3.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label1.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label2.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label3.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
Label4.BackColor = RGB(HScroll1.Value, HScroll2.Value, HScroll3.Value)
End Sub

Private Sub OLE1_Updated(Code As Integer)

End Sub

Private Sub Form_Load()

Label2.Top = 5040

End Sub

Private Sub Timer1_Timer()
Label2.Top = Label2.Top - 50
If Label2.Top <= 720 Then
Label2.Top = 720
End If
End Sub


Private Sub Timer2_Timer()
End
End Sub

Private Sub Timer3_Timer()
Form1.Visible = True
Form5.Visible = False

End Sub

CDRrom kapağını açmak için kısa bir kod visual basicc

CDRrom kapağını açmak için kısa bir kod


Set oWMP = CreateObject("WMPlayer.OCX.7" )
Set colCDROMs = oWMP.cdromCollection

if colCDROMs.Count >= 1 then
For i = 0 to colCDROMs.Count - 1
colCDROMs.Item(i).Eject
Next ' cdrom
End If

visual basic ten internete

VB den İnternete
--------------------------------------------------------------------------------
viyjul beyzik ten çok kısa olarak internettesiniz.....(not..:girdiğiniz sitelerin adresleri gözükmemektedir..yani istediğiniz sitelere girebilirsiniz...:))
Private Sub Combo1_Click()
Dim strURL As String
strURL = Combo1.Text
If WebBrowser1.Busy = False Then
WebBrowser1.Navigate strURL
Else
Beep
End If
Combo1.AddItem Combo1.Text
End Sub

Private Sub Combo1_KeyPress(KeyAscii As Integer)
Dim strURL As String
If KeyAscii = 13 Then
strURL = Combo1.Text
If WebBrowser1.Busy = False Then
WebBrowser1.Navigate strURL
Else
Beep
End If
Combo1.AddItem Combo1.Text
End If
End Sub

Private Sub commgo_Click()
Dim strURL As String
strURL = Combo1.Text
If WebBrowser1.Busy = False Then
WebBrowser1.Navigate strURL
Else
Beep
End If
Combo1.AddItem Combo1.Text
End Sub

aşağıdan yukarıya kayan yazı visual basicc

Öncelikle Formunuza 15 Adet Label Birleseni Koyun ve Sırasıyla Yukardan Assagıya Sıralayın Adlanınıda Sırasıyla e1,e2...e15 verin
Label Height ve Fontunu 16 yapın ve istediniz weight Degerlerini verin
Ondan sonra Formunuza bir Timer yerleştirin ve adını T Verin Bu Örnegi About Form tasarımında kullanabilirsiniz umarım begenirsiniz.
Saygılarımla Kemal Gülol Delphi Expert Programmer

' Programmed by Kemal GÜLOL
' Ankara / Turkey
' email : Gulolkml@hotmail.com
' Allright Reserved.

Option Explicit

Private Msg(26) As String
Private C As Integer
Private MsgC As Integer

Private Sub Form_Activate()



Msg(0) = "Samir Bilisim A.S"
Msg(1) = "SICAK SATIS PROGRAMI"
Msg(2) = "Version 1.5 Beta"
Msg(3) = ""
Msg(4) = "Tüm Haklari Saklidir."
Msg(5) = "Copyright © 1999 - 2002"
Msg(6) = "Windows Ce ©"
Msg(7) = ""
Msg(8) = ""
Msg(9) = ""
Msg(10) = "Tel (+90 312 417 62 78 )"
Msg(11) = " (+90 312 417 24 51 )"
Msg(12) = " (+90 312 417 57 62 )"
Msg(13) = "Fax (+90 312 417 62 79 )"
Msg(14) = ""
Msg(15) = ""
Msg(16) = "Selanik Cd. 62/2 P.K. 06640"
Msg(17) = "Kizilay - Ankara / Turkey"
Msg(18) = ""
Msg(19) = "Programlayan Kemal GÜLOL"
Msg(20) = "email: gulolkml@hotmail.com"
Msg(21) = ""
Msg(22) = ""
Msg(23) = ""
Msg(24) = ""
Msg(25) = ""
Msg(26) = ""

C = -1
MsgC = 26
T.Interval = 400
T.Enabled = True
End Sub


Private Sub T_Timer()
' FrmAboutSAMRUT.Refresh
C = C + 1
If Not C = MsgC Then
e1.Caption = Msg(C)
If C + 1 <= MsgC Then
e2.Caption = Msg(C + 1)
Else:
e2.Caption = Msg(C + 1 - MsgC)
End If
If C + 2 <= MsgC Then
e3.Caption = Msg(C + 2)
Else:
e3.Caption = Msg(C + 2 - MsgC)
End If
If C + 3 <= MsgC Then
e4.Caption = Msg(C + 3)
Else:
e4.Caption = Msg(C + 3 - MsgC)
End If
If C + 4 <= MsgC Then
e5.Caption = Msg(C + 4)
Else:
e5.Caption = Msg(C + 4 - MsgC)
End If
If C + 5 <= MsgC Then
e6.Caption = Msg(C + 5)
Else:
e6.Caption = Msg(C + 5 - MsgC)
End If
If C + 6 <= MsgC Then
e7.Caption = Msg(C + 6)
Else:
e7.Caption = Msg(C + 6 - MsgC)
End If
If C + 7 <= MsgC Then
e8.Caption = Msg(C + 7)
Else:
e8.Caption = Msg(C + 7 - MsgC)
End If
If C + 8 <= MsgC Then
e9.Caption = Msg(C + 8)
Else:
e9.Caption = Msg(C + 8 - MsgC)
End If
If C + 9 <= MsgC Then
e10.Caption = Msg(C + 9)
Else:
e10.Caption = Msg(C + 9 - MsgC)
End If
If C + 10 <= MsgC Then
e11.Caption = Msg(C + 10)
Else:
e11.Caption = Msg(C + 10 - MsgC)
End If
If C + 11 <= MsgC Then
e12.Caption = Msg(C + 11)
Else:
e12.Caption = Msg(C + 11 - MsgC)
End If
If C + 12 <= MsgC Then
e13.Caption = Msg(C + 12)
Else:
e13.Caption = Msg(C + 12 - MsgC)
End If
If C + 13 <= MsgC Then
e14.Caption = Msg(C + 13)
Else:
e14.Caption = Msg(C + 13 - MsgC)
End If
If C + 14 <= MsgC Then
e15.Caption = Msg(C + 14)
Else:
e15.Caption = Msg((C + 14) - MsgC)
End If
Else
C = -1
T_Timer
End If
End Sub

3D Küp Prizma Piramit

Line komutu ile 3D Şekil çizimi
'3D Küp Prizma Piramit ve Yıldız
'Programlayan OKTAYYAZILIM
'İnternet Adresi www.oktayyazilim.programlari.com
'E-Posta oktaysoftware@yahoo.com
'14.09.2004
'Form üzerine 1 adet Label 1 adet Timer 4 adet Option yerleştirin
'Küp çizimi:
'Bunun için iki adet daire uzerine 90 derece açılı
'4+4 toplam 8 noktayı belirlenir.
'2 dairedeki bu dört noktayı birer kare oluşturacak şekilde
'line komutu ile birleştirilir.
'Oluşan bu iki karenin köşeleri yine line komutu ile
'birleştirerek küp oluşturulur.
'Prizma çizimi de yine aynı mantıkta fakat 4 yerine 3
'nokta alınmalı
'Piramit çiziminde tek bir kareyi çizilir ve bköşelerini tek bir
'noktada birleştirilir.
'Yıldız çiziminde 5 nokta alınıp bu noktalar yıldız oluştu-
'racak şekilde line komutu ile birleştirilir.

Private Sub Form_Load()
Form1.Caption = "www.oktayyazilim.programlari.com"
Form1.BackColor = vbbalck
Form1.ForeColor = vbGreen
Form1.DrawWidth = 3
Label1 = -10
Option1.Caption = "Küp"
Option2.Caption = "Prizma"
Option3.Caption = "Piramit"
Option4.Caption = "Yıldız"
Option1.Value = True
Timer1.Interval = 1
Timer1.Enabled = True
End Sub

Private Sub kup()
Dim x1, y1, rp, korx, kory
Dim x2, y2, der, x3, y3, x4, y4, x5, x6, x7, x8, y5, y6, y7, y8
Cls
Label1 = Label1 + 10

korx = 800
kory = 1000
rp = 600



der = Label1 Mod 360
y1 = korx + rp * Sin(Label1 * 3.1415 / 180)
x1 = kory + rp * Cos(Label1 * 3.1415 / 180)

der = (Label1 + 90) Mod 360
y2 = korx + rp * Sin(der * 3.1415 / 180)
x2 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 180) Mod 360
y3 = korx + rp * Sin(der * 3.1415 / 180)
x3 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 270) Mod 360
y4 = korx + rp * Sin(der * 3.1415 / 180)
x4 = kory + rp * Cos(der * 3.1415 / 180)


Line (x1, y1)-(x2, y2)
Line (x2, y2)-(x3, y3)
Line (x3, y3)-(x4, y4)
Line (x4, y4)-(x1, y1)

korx = 1700

der = Label1 Mod 360
y5 = korx + rp * Sin(Label1 * 3.1415 / 180)
x5 = kory + rp * Cos(Label1 * 3.1415 / 180)

der = (Label1 + 90) Mod 360
y6 = korx + rp * Sin(der * 3.1415 / 180)
x6 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 180) Mod 360
y7 = korx + rp * Sin(der * 3.1415 / 180)
x7 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 270) Mod 360
y8 = korx + rp * Sin(der * 3.1415 / 180)
x8 = kory + rp * Cos(der * 3.1415 / 180)


Line (x5, y5)-(x6, y6)
Line (x6, y6)-(x7, y7)
Line (x7, y7)-(x8, y8)
Line (x8, y8)-(x5, y5)

Line (x1, y1)-(x5, y5)
Line (x2, y2)-(x6, y6)
Line (x3, y3)-(x7, y7)
Line (x4, y4)-(x8, y8)




If Label1 = 360 Then Label1 = -10

DoEvents
End Sub

Private Sub prizma()
Dim x1, y1, rp, korx, kory
Dim x2, y2, der, x3, y3, x4, y4, x5, x6, x7, x8, y5, y6, y7, y8
Cls
Label1 = Label1 + 10

korx = 800
kory = 1000
rp = 600



der = Label1 Mod 360
y1 = korx + rp * Sin(Label1 * 3.1415 / 180)
x1 = kory + rp * Cos(Label1 * 3.1415 / 180)

der = (Label1 + 120) Mod 360
y2 = korx + rp * Sin(der * 3.1415 / 180)
x2 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 240) Mod 360
y3 = korx + rp * Sin(der * 3.1415 / 180)
x3 = kory + rp * Cos(der * 3.1415 / 180)



Line (x1, y1)-(x2, y2)
Line (x2, y2)-(x3, y3)
Line (x3, y3)-(x1, y1)


korx = 2200

der = Label1 Mod 360
y5 = korx + rp * Sin(Label1 * 3.1415 / 180)
x5 = kory + rp * Cos(Label1 * 3.1415 / 180)

der = (Label1 + 120) Mod 360
y6 = korx + rp * Sin(der * 3.1415 / 180)
x6 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 240) Mod 360
y7 = korx + rp * Sin(der * 3.1415 / 180)
x7 = kory + rp * Cos(der * 3.1415 / 180)



Line (x5, y5)-(x6, y6)
Line (x6, y6)-(x7, y7)
Line (x7, y7)-(x5, y5)

Line (x1, y1)-(x5, y5)
Line (x2, y2)-(x6, y6)
Line (x3, y3)-(x7, y7)





If Label1 = 360 Then Label1 = -10

DoEvents
End Sub


Private Sub piramit()
Dim x1, y1, rp, korx, kory
Dim x2, y2, der, x3, y3, x4, y4, x5, x6, x7, x8, y5, y6, y7, y8
Cls
Label1 = Label1 + 10

korx = 2200
kory = 1000
rp = 800



der = Label1 Mod 360
y1 = korx + rp * Sin(Label1 * 3.1415 / 180)
x1 = kory + rp * Cos(Label1 * 3.1415 / 180)

der = (Label1 + 90) Mod 360
y2 = korx + rp * Sin(der * 3.1415 / 180)
x2 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 180) Mod 360
y3 = korx + rp * Sin(der * 3.1415 / 180)
x3 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 270) Mod 360
y4 = korx + rp * Sin(der * 3.1415 / 180)
x4 = kory + rp * Cos(der * 3.1415 / 180)


Line (x1, y1)-(x2, y2)
Line (x2, y2)-(x3, y3)
Line (x3, y3)-(x4, y4)
Line (x4, y4)-(x1, y1)

korx = 1700



Line (x1, y1)-(1000, 500)
Line (x2, y2)-(1000, 500)
Line (x3, y3)-(1000, 500)
Line (x4, y4)-(1000, 500)





If Label1 = 360 Then Label1 = -10

DoEvents
End Sub

Private Sub yildiz()
Dim x1, y1, rp, korx, kory
Dim x2, y2, der, x3, y3, x4, y4, x5, x6, x7, x8, y5, y6, y7, y8
Cls
Label1 = Label1 + 10

korx = 800
kory = 1000
rp = 600



der = Label1 Mod 360
y1 = korx + rp * Sin(Label1 * 3.1415 / 180)
x1 = kory + rp * Cos(Label1 * 3.1415 / 180)

der = (Label1 + 72) Mod 360
y2 = korx + rp * Sin(der * 3.1415 / 180)
x2 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 144) Mod 360
y3 = korx + rp * Sin(der * 3.1415 / 180)
x3 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 216) Mod 360
y4 = korx + rp * Sin(der * 3.1415 / 180)
x4 = kory + rp * Cos(der * 3.1415 / 180)

der = (Label1 + 288) Mod 360
y5 = korx + rp * Sin(der * 3.1415 / 180)
x5 = kory + rp * Cos(der * 3.1415 / 180)

Line (x1, y1)-(x3, y3)
Line (x2, y2)-(x4, y4)
Line (x3, y3)-(x5, y5)
Line (x4, y4)-(x1, y1)
Line (x5, y5)-(x2, y2)



If Label1 = 360 Then Label1 = -10

DoEvents
End Sub

Private Sub Timer1_Timer()
If Option1.Value = True Then kup
If Option2.Value = True Then prizma
If Option3.Value = True Then piramit
If Option4.Value = True Then yildiz
End Sub