Hafta sonu 15:00 - 18:00 arası "DJ EMRE" ile "Müzik Ekspres" programını dinlemek için TIKLAYINIZ
Canlı yayını dinlemek için bilgisayarınızda WINAMP kurulu olmalıdır.WINAMP indirmek için TIKLAYINIZ
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
Visual Basic içinde Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir) konusu , Evet arkadaşlar hiçbir forum sitesinde bulamazsınız bu kodları bir arada..Sürekli güncellenecektir..***TNSEZER***
Güzel bir ekran koruyucu
Kod:
Dim a As Long
Private Sub Timer1_Timer()
Line (800, 800)-(800, 800 + a), Int(Rnd ...
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
KAYIT OL
Yönetim Takımı
Üye Listesi
Tüm konuları okunmuş kabul et
19-04-2006, 16:37
#1 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
Evet arkadaşlar hiçbir forum sitesinde bulamazsınız bu kodları bir arada..Sürekli güncellenecektir..***TNSEZER***
Güzel bir ekran koruyucu
Kod:
Dim a As Long
Private Sub Timer1_Timer()
Line (800, 800)-(800, 800 + a), Int(Rnd * 65000)
Line (2000, 800)-(2000, 800 + a), Int(Rnd * 65000)
Line (3000, 800)-(3000, 800 + a), Int(Rnd * 65000)
Line (4000, 800)-(4000, 800 + a), Int(Rnd * 65000)
Line (5000, 800)-(5000, 800 + a), Int(Rnd * 65000)
Line (6000, 800)-(6000, 800 + a), Int(Rnd * 65000)
Line (7000, 800)-(7000, 800 + a), Int(Rnd * 65000)
Line (8000, 800)-(8000, 800 + a), Int(Rnd * 65000)
Line (9000, 800)-(9000, 800 + a), Int(Rnd * 65000)
Line (10000, 800)-(10000, 800 + a), Int(Rnd * 65000)
Line (11000, 800)-(11000, 800 + a), Int(Rnd * 65000)
Line (12000, 800)-(12000, 800 + a), Int(Rnd * 65000)
Line (13000, 800)-(13000, 800 + a), Int(Rnd * 65000)
Line (14000, 800)-(14000, 800 + a), Int(Rnd * 65000)
Line (15000, 800)-(15000, 800 + a), Int(Rnd * 65000)
Line (800, 800)-(800 + a, 800), Int(Rnd * 65000)
Line (800, 2000)-(800 + a, 2000), Int(Rnd * 65000)
Line (800, 3000)-(800 + a, 3000), Int(Rnd * 65000)
Line (800, 4000)-(800 + a, 4000), Int(Rnd * 65000)
Line (800, 5000)-(800 + a, 5000), Int(Rnd * 65000)
Line (800, 6000)-(800 + a, 6000), Int(Rnd * 65000)
Line (800, 7000)-(800 + a, 7000), Int(Rnd * 65000)
Line (800, 8000)-(800 + a, 8000), Int(Rnd * 65000)
Line (800, 9000)-(800 + a, 9000), Int(Rnd * 65000)
Line (800, 10000)-(800 + a, 10000), Int(Rnd * 65000)
Line (800, 11000)-(800 + a, 11000), Int(Rnd * 65000)
a = a + 50
End Sub
Yazi tipi uygulamasi
Kod:
Private Sub Check4_Click()
If Check4.Value = 1 Then
Check5.Value = 0
Text1.ForeColor = RGB(255, 0, 0)
End If
End Sub
Private Sub Check5_Click()
If Check5.Value = 1 Then
Check4.Value = 0
Text1.ForeColor = RGB(0, 255, 0)
End If
End Sub
Private Sub Check6_Click()
If Check4.Value = 1 Then
Check5.Value = 0
Text1.ForeColor = RGB(255, 0, 255)
End If
End Sub
Private Sub Command1_Click()
If Check1.Value = 1 Then
Text1.FontBold = True
Else
Text1.FontBold = False
End If
If Check2.Value = 1 Then
Text1.FontItalic = True
Else
Text1.FontItalic = False
End If
If Check3.Value = 1 Then
Text1.FontUnderline = True
Else
Text1.FontUnderline = False
End If
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
Text1.FontSize = Text1.FontSize - 5
End Sub
Private Sub Command4_Click()
Text1.FontSize = Text1.FontSize + 5
End Sub
Vscrollbar ile fomda arka plan rengi ayarlama
Kod:
Private Sub VScroll1_Change()
Form1.BackColor = _
RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub
Private Sub VScroll2_Change()
Form1.BackColor = _
RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub
Private Sub VScroll3_Change()
Form1.BackColor = _
RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub
19-04-2006, 16:40
#2 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Sayi bulma oyunu
Alt Alta 5 Tane Text Box Açyn ve 2 Tane de Command Buton Ekleyin...
Kod:
dim tes as integer
dim st as integer
dim sakla as integer
dim uyary as string
dim i as integer
________________________________
Private Sub Form_Load()
End Sub
________________________________
Private Sub Command1_Click()
tes = Text1.text
sakla = tes
Text4.text =sakla
Text1.text=""
End Sub
________________________________
Private Sub Command2_Click()
tes =Text1.text
st =Text2.text
If st = sakla Then
i = i + 1
uyary="Tebrikler i denemede bildiniz!"
Text5.text = i
End If
If st < sakla Then
i = i + 1
Text2.text = ""
uyary="Tahmininiz Küçük!"
Text5.text = i
End If
If st > sakla Then
i = i + 1
Text2.text = ""
uyary="Tahmininiz Büyük!"
Text5.text = i
End If
Text3.text = uyary
End Sub
Hesap makinasi
Kod:
Dim a As Double
Dim b As Double
Private Sub Command1_Click()
Label1.Caption = a & "1"
a = Label1.Caption
If a = 1 Then
Label1.Caption = "1"
End If
End Sub
Private Sub Command2_Click()
Label1.Caption = a & "2"
a = Label1.Caption
If a = 2 Then
Label1.Caption = "2"
End If
End Sub
Private Sub Command3_Click()
Label1.Caption = a & "3"
a = Label1.Caption
If a = 3 Then
Label1.Caption = "3"
End If
End Sub
Private Sub Command4_Click()
Label3.Caption = Val(a) + Val(b)
End Sub
Private Sub Command5_Click()
Label3.Caption = Val(a) * Val(b)
End Sub
Private Sub Command6_Click()
Label2.Caption = b & "1"
b = Label2.Caption
If b = 1 Then
Label2.Caption = "1"
End If
End Sub
Private Sub Command7_Click()
Label2.Caption = b & "2"
b = Label2.Caption
If b = 2 Then
Label2.Caption = "2"
End If
End Sub
Private Sub Command8_Click()
Label2.Caption = b & "3"
b = Label2.Caption
If b = 3 Then
Label2.Caption = "3"
End If
End Sub
List kutusunu access veritabanina baglamak
forma bi tane data nesnesi bi tane de list kutusu ekleyin.
Kod:
Private Sub Form_Activate()
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List1.AddItem (Data1.Recordset![mallar])
Data1.Recordset.MoveNext
Loop
End Sub
Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_stok"
End Sub
19-04-2006, 16:44
#3 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Bilgisayarin sesini açip kisabilirsiniz
1- Forma 1 tane modül, 6 tane label, 2 tane timer, 1 tane check kutusu, 2 tane slider kontrolü(MSCOMCTL.OCX) ekleyin.
''''''''''''''''''''''''''''Modüle eklenecek kisim''''''''''''''''''''''''''''
Kod:
Public Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long
Public Declare Function waveOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
Public Const MAXPNAMELEN = 32 ' max product name length (including NULL)
Public Type WAVEOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
dwFormats As Long
wChannels As Integer
dwSupport As Long
End Type
Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long
''''''''''''''''''''''''''''''''''Forma eklenecek kisim'''''''''''''''''''''''''''''''''''''''
Kod:
Private Sub Check1_Click()
Timer1.Interval = 0
Timer2.Interval = 0
End Sub
Private Sub Form_Load()
label1.caption="sag"
label2.caption="sol"
label3.caption="alçak"
label4.caption="yüksek"
label5.caption="alçak"
label6.caption="yüksek"
check1.caption="Kaydirma Göstergeleri Ayni Anda Hareket Etsin"
Dim lpc As WAVEOUTCAPS
If waveOutGetNumDevs() = 0 Then
MsgBox ("Ses çalacak donanmim yok")
End If
Call waveOutGetDevCaps(0, lpc, Len(lpc))
If lpc.wChannels = 0 Then
Slider2.Visible = False [m]'mono ise birini gizle[/m]
End If
If (lpc.dwSupport And 4) = 0 Then [m]'ses ayarini desteklemiyorsa ikisinide gizle[/m]
Slider1.Visible = False
Slider2.Visible = False
End If
If (lpc.dwSupport And 8) = 0 Then [m]'sol sag ses ayarini desteklemiyorsa birini gizle[/m]
Slider2.Visible = False
End If
Slider1.Min = 0
Slider1.Max = &HFFFF&
Slider1.TickFrequency = &HFFFF& / 10
Slider2.Min = 0
Slider2.Max = &HFFFF&
Slider2.TickFrequency = &HFFFF& / 10
Dim x, sol, sag, st [m]'su anki seviyeyi göster[/m]
Call waveOutGetVolume(0, x)
sol = x And &HFFFF& [m]'düsük seviyeli 2byte[/m]
st = Hex(x And &HFFFF0000)
If Len(st) > 4 Then
st = Mid(st, 1, Len(st) - 4) [m]'yüksek seviyeli 2 bayti al[/m]
Else
st = 0
End If
sag = CDbl("&h" & st)
Slider1.Value = sol
Slider2.Value = sag
End Sub
Sub sesayar()
Dim x, sol, sag, s
sol = Slider1.Value
sag = Slider2.Value
s = Val("&h" & Hex(sag) & String(4 - Len(Hex(sol)), "0") & Hex(sol) & "&")
Call waveOutSetVolume(0, s)
End Sub
Private Sub Slider1_Click()
sesayar
End Sub
Private Sub Slider1_Scroll()
If Check1.Value = 0 Then
Else
Timer1.Interval = 0
Timer2.Interval = 1
End If
sesayar
End Sub
Private Sub Slider2_Click()
sesayar
End Sub
Private Sub Slider2_Scroll()
If Check1.Value = 0 Then
Else
Timer2.Interval = 0
Timer1.Interval = 1
End If
sesayar
End Sub
Private Sub Timer1_Timer()
Slider1 = Slider2
End Sub
Private Sub Timer2_Timer()
Slider2 = Slider1
End Sub
Ek kontrollerin bulunduklari .ocx dosyalari
PictureBox, Label, TextBox, Image, ListBox, Combobox, OptionButton, CheckBox, ScrollBar, Frame, Timer, DriveListbox, DirectoryListBox, FileListBox, Shape, Line, Data Kontrolleri herhangi bir dosyaya ihtiyaç duymaksizin araççubugundaki (toolbox) yerini alir. Ancak diger kontrolleri kullanabilmek için o kontrollerin bulundugu OCX dosyasini Vb'ye eklemek gerekir.
Asagidaki tabloda Hangi OCX dosyasinda hangi kontrollerin bulundugu gösteriliyor. Bu Controllerden birini kullanabilmek için "Project" / "Components" menülerini takip edip Listeden seçebilirsiniz, Eger listede yoksa "Browse" dügmesine basin ve dosyayi bulup seçin.
Component Adi Dosya Adi Kontroller
Kod:
Microsoft(MS) ADO Data Cont. 6.0 MSADODC.OCX ADO Data Control
MS Chart Control 5.5 MSCHART.OCX Microsoft Chart
MS Comm Control 6.0 MSCOMM32.OCX MSComm
MS Common Dialog Control 6.0 COMDLG32:OCX Common Dialog
MS Data Bound Grid Control 5.0 DBGRID32.OCX DBGrid
MS Data Bound List Controls 6.0 DBLIST32.OCX DBList, DBCombo
MS Data Repeater Control 6.0 MSDATREP.OCX DataRepeater
MS Data Grid Control 6.0 MSDATGRD.OCX DataGrid
MS Data List Controls 6.0 MSDATLST.OCX DataList, DataCombo
MS FlexGrid Control 6.0 MSFLXGRD.OCX MsFlexGrid
MS Grid Control GRID32.OCX Grid
MS Hierarchical Flex Grid Control 6.0 MSHFLXGD.OCX MSHFlexGrid
MS Internet Transfer Control 6.0 MSINET.OCX Inet
MS MAPI Controls 6.0 MSMAPI32.OCX MapiMessages, MAPISession
MS MaskedEdit Control 6.0 MSMASKE32.OCX MaskedEdit
MS Multimedia Control 6.0 MCI32.OCX Multimedia MCI
MS PictureClip Control 6.0 PICCLP32.OCX PictureClip
MS RemoteData Control 6.0 MSRDC20.OCX RemoteData
MS RichTextBox Control 6.0 RICHTX.OCX RichTextBox
MS SysInfo Conterol 6.0 SYSINFO.OCX SysInfo
MS TabbedDialog Control 6.0 TABCTL32.OCX Ms Tab Control
MS Windows Common Controls 6.0 MSCOMCTL.OCX TabStrip, Toolbar, StatusBar,
ProgressBar, TreeView, ListView,
ImageList, Slider, ImageCombo
MS WIndows Common Controls-2 6.0 MSCOMCTL2.OCX Animation, UpDown, MonthView,
DTPicker, FlatScrollbar
MS Windows Common Controls-3 6.0 MSCOMCTL3.OCX CoolBar
MS Winsock Control 6.0 MSWINSOCK.OCX Winsock
Bagzen Programinizi Baska Bir Bilgisayarda çalistirmak istediginizde MSCOMCTL.OCX dosyasinin bilgisayarda olmadigi ve gerektigi Hatasi verir. Iste programlarininzda kullandiginiz kontrollere göre .OCX dosyalarini da Setupa, yada Programiniza dahil ederseniz, Bu tip sorunlar olmaz.
19-04-2006, 16:47
#4 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Program yaziyosaniz lazimdir
1_ Visual Basic Service Pack 6.0 (vb'nin sp 6 güncellestirmesidir.)
http://www.microsoft.com/downloads/i...82/Vs6sp6B.exe
2_ Visual Basic Runtime 6.0 (vb'nin çalisma dosyalaridir)
http://download.microsoft.com/downlo...vbrun60sp3.EXE
3_ Microsoft Data Access Component (MDAC) 2.5 (veritabani uygulamasi olan programlar için access yamasidir)
http://www.microsoft.com/downloads/i...S/MDAC_TYP.EXE
4_ Visual Basic Kod Bankasi 1.7 (Tam 2081 adet vb kodu içerir)
http://www.sezginweb.com/programlar/vbkodbank17.exe
5_ Setup Pro (Türkçe bir setup hazrlama programidir)
http://www.sezginweb.com/programlar/setuppro.rar
6_ Cyrstal Reports 10 (vb üzerinde raporlama yapmak isteyenler için)
http://ftp.crystaldecisions.com/outg.../CR10DevEn.exe
7_ 1000 adet hazir icon (programinizda kullanabileceginiz 100 adet hazir icon bu dosyanin içinde)
http://www.vbasicmaster.com/zips/icons.zip
8_ Help Creator (vb'de yardim(help) dosyalari hazirlayabilirsiniz.)
http://www.breittechnologies.com/pro...torInstall.exe
9_ API-Guide V 3.7.854 (Apilerle ilgili birçok bilgi içeriyor)
http://www.student.kuleuven.ac.be/~m....7/agsetup.exe
Forma media playeri çagirma
Kod:
Private Sub Command11_Click()
Call Shell("C:\Program Files\Windows Media Player\wmplayer.exe /prefetch:1.exe", 1)
End Sub
Dosyanin tam yolunu yazmak zorunda degilsiniz
Kod:
Private Sub Form_Load()
Dim Path As String
Path = "c:\windows\media\tada.wav"
MsgBox Path
Path = StrReverse(Split(StrReverse(Path), "\")(0))
MsgBox Path
End Sub
19-04-2006, 16:51
#5 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Internetteki access veritabanindaki kayit sayisi
Project/Components'ten
Microsoft Internet Transfer Control
Microsoft Ado Data Control
Microsoft Datagrid Control
projenize eklyin
1 adet label ve 1 adet command ekleyin
kodlari oldugu gibi forma yapistirin
Kod:
Private Sub Command1_Click()
Label1.Caption = "Veritabaninda toplam " & Adodc1.Recordset.RecordCount & " kayit var"
End Sub
Private Sub Form_Load()
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=\\www.sezginweb.com\deneme\kayit.mdb"
Adodc1.RecordSource = "tblogrenciler"
Set DataGrid1.DataSource = Adodc1
End Sub
Her türlü müzik dosyasini çalma
project componentten microsoft common dialog control ü ekleyin
4 command 1 tanede text kutusu ekleyin
olduğu gibi forma yapıştırn
Kod:
Private 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
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Sub Command1_Click()
Dim Hata As Long
Dim HataMesaji As String * 128
'Mesajı gönderiyoruz
Hata = mciSendString("open " & Chr$(34) & Text1.Text & Chr$(34) & " alias YeniSes", 0, 0, 0)
'Hata Mesajını Alıyoruz
mciGetErrorString Hata, HataMesaji, 128
MsgBox HataMesaji
End Sub
Private Sub Command2_Click()
mciSendString "play YeniSes", 0, 0, 0
End Sub
Private Sub Command3_Click()
mciSendString "close Yenises", 0, 0, 0
End Sub
Private Sub Command4_Click()
On Error GoTo error
With CommonDialog1
.CancelError = True
.DialogTitle = "Ses Dosyası aç_-_-_-_-Sunasoft Yazılım Bilgisayar-_-_-_-_"
.Filter = "Şarkı Dosyaları (*.mp3) |*.mp3; |Ses Dosyaları (*.wav) |*.wav; |Midi Dosyaları (*.mid) |*.mid"
.InitDir = "c:\"
.ShowOpen
If Len(.FileName) = 0 Then Exit Sub
Text1.Text = .FileName
cmdPlay.SetFocus
End With
error:
End Sub
Private Sub Form_Load()
'''Buraları bilmesenizde olur ben sadece nasıl çalıştığını görün diya yaptım
Left = (Screen.Width - Width) \ 2
Top = (Screen.Height - Height) \ 2
Command1.Caption = "Yükle"
Command2.Caption = "Çal"
Command3.Caption = "Dur"
Command4.Caption = "Gözat"
Form1.Height = 4920
Form1.Width = 8820
Command1.Top = 720
Command1.Left = 480
Command2.Top = 1320
Command2.Left = 480
Command3.Top = 1920
Command3.Left = 480
Command4.Top = 2400
Command4.Left = 6600
Text1.Top = 2520
Text1.Left = 480
Text1.Height = 285
Text1.Width = 6015
End Sub
Vb üzerinden excelde arama yapmak
Project/References menülerinden "Microsoft Excel 10.0 Object Library" ekleyin,
Formunuza 9 adet text kutusu, 9 adet label ve bir adet command butonu ekleyin,
ve aşağıdaki kodları olduğu gibi forma yapıştırın ve çalıştırın.
Kod:
Dim c As Excel.Range
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Sub ExcelAra()
On Error GoTo hata
Set xlApp = New Excel.Application
Text2.Text = ""
Set xlBook = Workbooks.Open(App.Path & "\devlet_kurumlari.xls", , True)
Set xlSheet = xlBook.Worksheets("sheet 1")
With xlSheet.Range("a1:c65536")
Set c = .Find(Trim(Text1.Text), lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Text2.Text = c.Address
Range(Text2.Text).Select
Text3.Text = Excel.ActiveCell.Row
'??????_______Kurum Adı
Range("$d$" & Text3.Text).Select
Text4.Text = Excel.ActiveCell
'??????_______Kurum İli
Range("$a$" & Text3.Text).Select
Text5.Text = Excel.ActiveCell
'??????_______Kurum İlçesi
Range("$b$" & Text3.Text).Select
Text6.Text = Excel.ActiveCell
'??????_______Kurum Telefonu
Range("$e$" & Text3.Text).Select
Text7.Text = Excel.ActiveCell
MaskEdBox1.Text = Excel.ActiveCell
'??????_______Kurum Fax
Range("$f$" & Text3.Text).Select
Text8.Text = Excel.ActiveCell
'??????_______Kurum Adres
Range("$g$" & Text3.Text).Select
Text9.Text = Excel.ActiveCell
Do
c.Interior.Pattern = xlPatternGray50
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
If Text2.Text = "" Then Text2.Text = "Bulunamadı..."
xlBook.Close False
xlApp.Quit
Exit Sub
hata:
MsgBox Err.Description
End Sub
Private Sub Command1_Click()
ExcelAra
End Sub
19-04-2006, 16:55
#6 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Bilgisayar her açildiginda program çalissin mi çalismasin mi?
Forma bi tane checkbox, bi tane label, bitane textbox, bitane de data nesnesi koyun.
bi tane veritabanı oluşturun(access) adınıda sabit.mdb yapın.bu veritabanında bi tane tablo oluşturun adını tbl_kontrol yapın.Bu tabloda bi tane alan oluşturun adını da windows_acilis yapın.
text1 nesnesi data1'e bağlayın.
label'in captionuna "Bilgisayar her açıldığında program çalışsın" yazın.
Bu veritabanı programınızla aynı klasörde olsun.
'''''''''''''''''''''''''''''BİTTİ'''''''''''''''' ''''''''''''''''''''''''''''''
Kod:
Private Sub Check1_Click()
If Check1.Value = 0 Then
Text1.Text = "1"
End If
If Check1.Value = 1 Then
Text1.Text = "2"
End If
Dim KayitDefteri As Object
Set KayitDefteri = CreateObject("wscript.shell")
If Text1.Text = "1" Then
KayitDefteri.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN\" & App.EXEName, "" & "" & "" & ""
End If
If Text1.Text = "2" Then
KayitDefteri.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
End If
End Sub
Private Sub Form_Activate()
If Text1.Text = "1" Then
Check1.Value = 0
End If
If Text1.Text = "2" Then
Check1.Value = 1
End If
End Sub
Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_kontrol"
Text1.DataField = "windows_acilis"
End Sub
Winampa benziyor
İlk Yapılacaklar :
1- Bi tane veritabanı oluşturun, adı sabit.mdb olsun.
2- Bu veritabanında bi tane tablo oluşturun adı tbl_muzikyayini olsun.
3- Bu tabloyada iki tane alan yerleştirin, biri zil_müzikler_toplanmis diğeri zil_müzikler_acilmis olsun.
4- Sonra forma; 2 list kutusu, 4 text kutusu, 1 comman button, 1 data nesnesi, 2 timer, 1 tanede commondialog control ekleyin.
5- Commanbuttonun captionuna ekle yazın.
6- Timerlerin interval özelliğini 1 yapın.
Açıklama :
1- Commandbutonun captionuna ekle yazın, bununla belirttiğimiz bir klasörden müzik dosyasını list2'ye akatarıcaz.list2'de dosyanın tam yolu yazacağı için, ordan list1'e sadece müzik dosyasının adı gelecek.
2- Text4 ile müziğin şu an çalıp çalmadığını kontrol edicez, çalıyosa playing yazacak, çalmıyorsa stoping yazacak.
3- Timer2 ile durumu kontrol edicez müzik dosyası çalıyomu çalmıyomu, buna göre bir sonraki müzik dosyasını çaldırtıcaz.
4- Timer1 ile de duruma göre bir sonraki müzik dosyasını çaldırıcaz.
5- Text3 ile çalınan müzik dosyasının uzunluğunu dakika cinsinden göstericez.
VEEEE AŞAĞIDAKİ KODLARI OLDUĞU GİBİ FORMA YAPIŞTIRICAZ
Kod:
Private 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
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Function StripPath(T$) As String '''''''Dosyanın kısa adını gösteren kod
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
ct% = x%
x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
Private Sub Command1_Click() '''''Projemize müzik dosyası buradan ekleniyor
On Error Resume Next
Data1.Recordset.AddNew
Data2.Recordset.AddNew
With CommonDialog1
'On Cancel do nothing
.CancelError = True
.DialogTitle = "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\Sunasoft Yazılım///////////////////////////////////"
.Filter = "Hepsi ( *.mp3 *.wav *.mid ) |*.mp3;*.wav;*.mid|Şarkı Dosyaları (*.mp3) |*.mp3; |Ses Dosyaları (*.wav) |*.wav; |Midi Dosyaları (*.mid) |*.mid"
.InitDir = App.Path & "\müzikler\"
.ShowOpen
'Handle no filename
If Len(.FileName) = 0 Then Exit Sub
Text1.Text = .FileName
List1.AddItem Text1.Text
file = StripPath(Text1.Text)
Text2.Text = file
List2.AddItem file
List1.Clear
List2.Clear
Form_Activate
End With
error: 'Do nothing
End Sub
Private Sub Form_Activate() '''Burada list kutusunu veritabanına bağlıyoruz
On Error Resume Next
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List1.AddItem (Data1.Recordset![zil_müzikler_acilmis])
Data1.Recordset.MoveNext
Loop
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List2.AddItem (Data1.Recordset![zil_müzikler_toplanmis])
Data1.Recordset.MoveNext
Loop
End Sub
Private Sub Form_Load() ''''Data nesenesine bağlantı ayarları buradan yapılıyor
mciSendString "close Yenises", 0, 0, 0 'Müzik dosyasını kapat
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_muzikyayini"
End Sub
Private Sub Form_Unload(Cancel As Integer) '''Çıkarken çalan müziği kapatıyoruz
mciSendString "close Yenises", 0, 0, 0
End Sub
Private Sub List2_Click() ''''List2'de tıklanan müziği çaldırtıyoruz
On Error Resume Next
Dim i
For i = 0 To List2.ListCount - 1
If List2.Selected(i) Then
mciSendString "close Yenises", 0, 0, 0
Hata = mciSendString("open " & Chr$(34) & List2.List(i) & Chr$(34) & " alias YeniSes", 0, 0, 0)
mciSendString "play YeniSes", 0, 0, 0 'Müziği oynatma kısmı
Dim Dondur As String * 128 '''Burada adı geçen dondur=çalmasüresidir
mciSendString "status YeniSes length", Dondur, 128, 0
Text3.Text = ((Dondur / 60000))
End If
Next
End Sub
Private Sub Timer1_Timer()
If Text4.Text = "stopped" Then 'Eğer müzik dosyası çalmıyorsa demek oluyo.
If List2.ListIndex = List2.ListCount - 1 Then '''Eğer listenin sonuna gelinmişşe
List2.Selected(0) = True '''Listenin en başındakini seç
Else 'Gelmemişse daha o zaman alttaki koddan devam et
List2.Selected(List2.ListIndex + 1) = True ''Bir önceki dosyadan sonrakini çalmaya devam et
End If
For i = 0 To List2.ListCount - 1
If List2.Selected(i) Then
mciSendString "close Yenises", 0, 0, 0
Hata = mciSendString("open " & Chr$(34) & List2.List(i) & Chr$(34) & " alias YeniSes", 0, 0, 0)
mciSendString "play YeniSes", 0, 0, 0
Dim Dondur As String * 128
mciSendString "status YeniSes length", Dondur, 128, 0
Text3.Text = ((Dondur / 60000))
End If
Next
End If
End Sub
Private Sub Timer2_Timer() '''Durumu sürekli olarak kontrol et
Dim Durum As String * 128
mciSendString "status YeniSes mode", Durum, 128, 0
Text4.Text = Durum
End Sub
Araba yarisi
Evet Arkadaşlar merhaba şimdi sizinle araba yarışı yapacagız
Araçlar : 1) iki tane Shape ekliyoruz bunlar araba olucak bu Shape adını Shape1 ve Shape2 yapıyoruz.
2) Timer ekliyoruz Left 5280 Top 3120 olarak değiştiriyoruz.
3) Command buton ekliyoruz
Aşağıda vermiş olduğum kodu ekliyoruz bu kadar.
Kod:
Private Sub Command1_Click()
Timer1.Interval = 10
Timer2.Interval = 10
End Sub
Private Sub Form_Load()
End Sub
Private Sub Timer1_Timer()
Randomize
g = Rnd(100) * 100
Shape1.Move Shape1.Left + g
If Shape1.Left >= 8000 Then
MsgBox ("kazanan pembe araba")
End
End If
End Sub
Private Sub Timer2_Timer()
Randomize
f = Rnd(100) * 100
Shape2.Move Shape2.Left + f
If Shape2.Left >= 8000 Then
MsgBox ("kazanan beyaz araba")
End
End If
End Sub
19-04-2006, 16:57
#7 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Oyun yasin
' 2 adet timer 1 label 1 pictrue box ve bir tane command tuşu form da bulunması gerekenlerdendir
Dim satirsayisi, sutunsayisi, kutusayisi, puan
Kod:
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.Left = Command1.Left + 100
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyLeft: Command1.Left = Command1.Left - 15
Case vbKeyRight: Command1.Left = Command1.Left + 15
If Command1.Left >= Form1.ScaleWidth - Command1.Width Then
Command1.Left = Form1.ScaleWidth - Command1.Width
End If
End Select
End Sub
Private Sub Form_Load()
Caption = "yasin çakmak"
Dim i, j, k
Show
ScaleMode = 3 'pixel
KeyPreview = True
satirsayisi = 5
sutunsayisi = 10
kutusayisi = satirsayi * sutunsayisi
Timer1.Interval = 10
Timer2.Interval = 10
Command1.Top = ScaleHeight - Label1.Height
Label1 = "0 "
Shape1.Shape = 3
Shape1.FillStyle = 7
Shape1.Width = 18
Shape1.Height = 18
Picture1(0).Width = 60
Picture1(0).Height = 20
widh = Picture1(0).Width * sutunsayisi * Screen.TwipsPerPixelX + 30
Picture1(0).Move 0, 0
Picture1(0).BackColor = QBColor(1)
For i = 1 To satirsayisi
For j = 1 To sutunsayisi
k = k + 1
Load Picture1(k)
Picture1(k).Left = Picture1(k - 1).Left + Picture1(k).Width
Picture1(k).Top = (i - 1) * Picture1(k).Height
Picture1(k).Visible = True
Picture1(k).BackColor = QBColor(i)
Next
Picture1(k).Left = 0
Next
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.Left = X
End Sub
Private Sub Timer1_Timer()
Static xa, ya
If IsEmpty(xa) Then xa = 10: ya = 10
If Shape1.Left <= 0 Then xa = -xa
If Shape1.Left >= ScaleWidth Then xa = -xa
If Shape1.Top < 0 Then ya = -ya
If (Shape1.Top >= Command1.Top) And (Shape1.Top < (Command1.Top + Command1.Height)) And Shape1.Left > Command1.Left And Shape1.Left < (Command1.Left + Command1.Width) Then ya = -ya
If Shape1.Top >= ScaleHeight Then
MsgBox "oyun bitti"
Timer1.Interval = False
End
End If
Dim i, j, k
k = -1
For i = 1 To sutunsayisi
For j = 1 To satirsayisi
k = k + 1
If Picture1(k).Visible = True And Shape1.Left >= Picture1(k).Left And Shape1.Left < (Picture1(k).Left + Picture1(k).Width) And Shape1.Top <= (Picture1(k).Top + Picture1(k).Height) Then
Picture1(k).Visible = False
kutusayisi = kutusayisi - 1
ya = -ya
puan = puan + 100
Label1 = puan
End If
Next
Next
Shape1.Left = Shape1.Left + xa
Shape1.Top = Shape1.Top + ya
If kutusayisi = 1 Then
MsgBox ("tebrikler")
End If
End Sub
Private Sub Timer2_Timer()
Picture1(Rnd * (satirsayisi * sutunsayisi - 1)).BackColor = QBColor(Rnd * 15)
End Sub
Yanip sönen buton
Kod:
Private Sub Timer1_timer
command1.backgroundcolor = ffff00
Command1.backgroundcolor=0f0f
end sub
Basit bir kronometre
Kod:
Private Sub basla_Click()
Timer1.Enabled = True
Timer1.Interval = 1000
End Sub
Private Sub durudur_Click()
Timer1.Enabled = False
Label8.Caption = saat
Label9.Caption = dakika
Label10.Caption = saniye
End Sub
Private Sub Timer1_Timer()
Label3.Caption = Now
saniye = saniye + 1
If saniye = 59 Then
dakika = dakika + 1
saniye = 0
End If
If dakika = 59 Then
saat = saat + 1
dakika = 0
End If
Label4.Caption = saat
Label5.Caption = dakika
Label6.Caption = saniye
End Sub
19-04-2006, 17:00
#8 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Ethernet kartinin mac adresini alma
Kod:
Private Const NCBASTAT As Long = &H33
Private Const NCBNAMSZ As Long = 16
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private Const HEAP_GENERATE_EXCEPTIONS As Long = &H4
Private Const NCBRESET As Long = &H32
Private Type NET_CONTROL_BLOCK
ncb_command As Byte
ncb_retcode As Byte
ncb_lsn As Byte
ncb_num As Byte
ncb_buffer As Long
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte
ncb_sto As Byte
ncb_post As Long
ncb_lana_num As Byte
ncb_cmd_cplt As Byte
ncb_reserve(9) As Byte
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(5) As Byte
rev_major As Byte
reserved0 As Byte
adapter_type As Byte
rev_minor As Byte
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NET_CONTROL_BLOCK) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Function GetMACAddress() As String
Dim tmp As String
Dim pASTAT As Long
Dim NCB As NET_CONTROL_BLOCK
Dim AST As ASTAT
NCB.ncb_command = NCBRESET
Call Netbios(NCB)
NCB.ncb_callname = "* "
NCB.ncb_command = NCBASTAT
NCB.ncb_lana_num = 0
NCB.ncb_length = Len(AST)
pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, NCB.ncb_length)
If pASTAT = 0 Then
Debug.Print "memory allocation failed!"
Exit Function
End If
NCB.ncb_buffer = pASTAT
Call Netbios(NCB)
CopyMemory AST, NCB.ncb_buffer, Len(AST)
tmp = Format$(Hex(AST.adapt.adapter_address(0)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(1)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(2)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(3)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(4)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(5)), "00")
HeapFree GetProcessHeap(), 0, pASTAT
GetMACAddress = tmp
End Function
Private Sub Form_Load()
MsgBox "Ethernet kartının MAC adresi: " + GetMACAddress()
End Sub
Basit bir screen saver
Kod:
Declare Function ShowCursor Lib "user32" (ByVal fShow As Integer) As Integer
Global maxLines As Integer
Sub endScrnSave()
showmouse
End
End Sub
Sub HideMouse()
While ShowCursor(False) >= 0
Wend
End Sub
Sub main()
BlankForm.Show
End Sub
Sub showmouse()
While ShowCursor(True) < 0
Wend
End Sub
'Formuna bir tane timer ekle interval=100 yap
'Formun özelliklerini border style=none yap
'Formun backcolor'unu siyah yap ve aşağıdaki kodu pastele.
'exe file yaparkende exe yi scr olarak değiştir windows\ system yapıştır.
'hadi kolay gelsin. Batuge'den :)
Dim lastX, lastY
Dim numlines
Sub form_Keydown(Keycode As Integer, Shift As Integer)
endScrnSave
End Sub
Private Sub Form_Load()
Move 0, 0, Screen.Width, Screen.Height
HideMouse
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If IsEmpty(lastX) Or IsEmpty(lastY) Then
lastX = X
lastY = Y
End If
If Abs(lastX - X) > 2 Or Abs(lastY - Y) > 2 Then
endScrnSave
End If
lastX = X
lastY = Y
End Sub
Private Sub Timer1_Timer()
Dim CX, CY, Radius, Limit
ScaleMode = 3
CX = ScaleWidth / 2
CY = ScaleHeight / 2
If CX > CY Then Limit = CY Else Limit = CX
For Radius = 0 To Limit
Circle (CX, CY), Radius, RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Next Radius
End Sub
Basit tetris
Kod:
Option Explicit
Private i, k, durum, renk, r, s, level, puan
Private iaktifsekilkare(3) As Integer
Private devam(3) As Boolean
Private devamet As Boolean
Private sola(3) As Boolean
Private solagit As Boolean
Private saga(3) As Boolean
Private sagagit As Boolean
Private sil(11) As Boolean
Private Sub form_keydown(keycode As Integer, shift As Integer)
On Error Resume Next
If keycode = vbKeyLeft Then
If Not (iaktifsekilkare(0) Mod 10 = 1) Then
If Shape1(iaktifsekilkare(0) - 1).Visible = False Then
sola(0) = True
Else
sola(0) = False
End If
If (iaktifsekilkare(1) - 1 = iaktifsekilkare(0)) Then
sola(1) = True
Else
sola(1) = False
End If
End If
If ((iaktifsekilkare(2) - 1 = iaktifsekilkare(0)) Or (iaktifsekilkare(2) - 1 = iaktifsekilkare(1))) Then
sola(2) = True
Else
If Shape1(iaktifsekilkare(2) - 1).Visible = False Then
sola(2) = True
Else
sola(2) = False
End If
End If
If ((iaktifsekilkare(3) - 1 = iaktifsekilkare(0)) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(1)) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(1) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(2)))) Then
sola(3) = True
Else
If Shape1(iaktifsekilkare(3) - 1).Visible = False Then
sola(3) = True
Else
sola(3) = False
End If
End If
For i = 0 To 3
If sola(i) = True Then
solagit = True
Else
solagit = False
GoTo soladevam
End If
Next
soladevam:
If solagit = True Then
If solagit = True Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) - 1
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End If
End If
End If
If keycode = vbKeyRight Then
If Not (iaktifsekilkare(3) Mod 10 = 0) Then
If Shape1(iaktifsekilkare(3) + 1).Visible = False Then
saga(3) = True
Else
saga(3) = False
End If
If (iaktifsekilkare(2) + 1 = iaktifsekilkare(3)) Then
saga(2) = True
Else
If Shape1(iaktifsekilkare(2) + 1).Visible = False Then
saga(2) = True
Else
saga(2) = False
End If
End If
If ((iaktifsekilkare(1) + 1 = iaktifsekilkare(3)) Or (iaktifsekilkare(1) + 1 = iaktifsekilkare(2))) Then
saga(1) = True
Else
If Shape1(iaktifsekilkare(1) + 1).Visible = False Then
saga(1) = True
Else
saga(1) = False
End If
End If
If ((iaktifsekilkare(0) + 1 = iaktifsekilkare(3)) Or (iaktifsekilkare(0) + 1 = iaktifsekilkare(2)) Or (iaktifsekilkare(0) + 1 = iaktifsekilkare(1))) Then
saga(0) = True
Else
If Shape1(iaktifsekilkare(0) + 1).Visible = False Then
saga(0) = True
Else
saga(0) = False
End If
End If
For i = 0 To 3
If saga(i) = True Then
sagagit = True
Else
sagagit = False
GoTo sagadevam
End If
Next
sagadevam:
If sagagit = True Then
For i = 3 To 0 Step -1
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) + 1
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End If
End If
If keycode = vbKeyDown Then
Timer1.Enabled = False
Timer1.Interval = 10
Timer1.Enabled = True
End If
If keycode = vbKeySpace Then
Select Case k
Case 1
If durum = 1 Then
On Error Resume Next
If Shape1(iaktifsekilkare(1) - 20).Visible = False And Shape1(iaktifsekilkare(1) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1) - 20
iaktifsekilkare(1) = iaktifsekilkare(1) - 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(1) + 20
durum = 2
End If
ElseIf durum = 2 Then
On Error Resume Next
If Shape1(iaktifsekilkare(2) - 1).Visible = False And Shape1(iaktifsekilkare(2) + 1).Visible = False And Shape1(iaktifsekilkare(2) + 2).Visible = False And (Not iaktifsekilkare(2) Mod 10 = 1) And (iaktifsekilkare(2) Mod 10 < 9) And (Not (iaktifsekilkare(2) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 1
iaktifsekilkare(1) = iaktifsekilkare(2)
iaktifsekilkare(2) = iaktifsekilkare(2) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 2
If durum = 1 Then
If iaktifsekilkare(2) < 200 Then
If Shape1(iaktifsekilkare(2) + 10).Visible = False And Shape1(iaktifsekilkare(3) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(3) - 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(0) - 11).Visible = False And Shape1(iaktifsekilkare(0) - 10).Visible = False And Not (iaktifsekilkare(0) Mod 10 = 1) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 11
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 3
If durum = 1 Then
If iaktifsekilkare(2) < 200 Then
If Shape1(iaktifsekilkare(2) + 10).Visible = False And Shape1(iaktifsekilkare(0) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 10
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(2)
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(2) - 9).Visible = False And Shape1(iaktifsekilkare(2) - 10).Visible = False And Not (iaktifsekilkare(2) Mod 10 = 0) And Not (iaktifsekilkare(0) Mod 10 = 1) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1)
iaktifsekilkare(1) = iaktifsekilkare(0) - 9
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(1) + 1
durum = 1
End If
End If
Case 4
Case 5
If durum = 1 Then
If iaktifsekilkare(1) < 190 Then
If Shape1(iaktifsekilkare(1) + 10).Visible = False And Shape1(iaktifsekilkare(1) + 20).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(0) + 1
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(3) + 10).Visible = False And Shape1(iaktifsekilkare(0) - 1).Visible = False And (Not (iaktifsekilkare(0) Mod 10 < 2)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 3
End If
ElseIf durum = 3 Then
If Shape1(iaktifsekilkare(2) - 10).Visible = False And Shape1(iaktifsekilkare(2) - 20).Visible = False And iaktifsekilkare(2) > 20 Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) + 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1 - 20
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 4
End If
ElseIf durum = 4 Then
If Shape1(iaktifsekilkare(0) - 10).Visible = False And Shape1(iaktifsekilkare(3) + 1).visible0false And (Not (iaktifsekilkare(3) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 6
If durum = 1 Then
If Shape1(iaktifsekilkare(2) - 1).Visible = False And Shape1(iaktifsekilkare(2) - 11).Visible = False And iaktifsekilkare(2) > 20 Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 11
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 2
End If
ElseIf durum = 2 Then
On Error Resume Next
If Shape1(iaktifsekilkare(3) + 1).Visible = False And (Not (iaktifsekilkare(3) Mod 10 = 0)) And Shape1(iaktifsekilkare(2) + 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(0) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 3
End If
ElseIf durum = 3 Then
On Error Resume Next
If Shape1(iaktifsekilkare(0) - 1).Visible = False And Shape1(iaktifsekilkare(1) + 10).Visible = False And (Not (iaktifsekilkare(0) Mod 10 = 1)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 4
End If
ElseIf durum = 4 Then
If Shape1(iaktifsekilkare(2) + 1).Visible = False And Shape1(iaktifsekilkare(2) - 9).Visible = False And (Not (iaktifsekilkare(1) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(2) = iaktifsekilkare(1) - 9
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 1
End If
End If
End Select
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End Sub
Private Sub form_load()
'şekilleri yerleştirelim
For i = 0 To 20
For k = 1 To 10
Load Shape1(10 * i + k)
If k = 1 Then
Shape1(i * 10 + k).Left = Shape1(0).Left + Shape1(0).Width
Shape1(i * 10 + k).Top = Shape1(0).Top
Else
Shape1(i * 10 + k).Left = Shape1(i * 10 + k - 1).Left + Shape1(i * 10 + k - 1).Width
Shape1(i * 10 + k).Top = Shape1(0).Top
End If
Next
Shape1(0).Top = Shape1(0).Top - Shape1(0).Height
Next
Shape2.Move Shape1(1).Left - 5, Shape1(210).Top - 5, 10 * Shape1(0).Width + 10, Shape1(0).Height * 20 + 10
Call sekilsec
For i = 0 To 10
Shape1(i).Visible = True
Next
level = 0
puan = 0
Label1.Caption = "level" & level
Label2.Caption = "punanınız:" & puan
End Sub
Private Sub sekilsec()
Randomize Timer
k = Int(Rnd * 6) + 1
Select Case k
Case 1: iaktifsekilkare(0) = 204
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 2: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 196
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 3: iaktifsekilkare(0) = 205
iaktifsekilkare(1) = 196
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 197
durum = 1
Case 4: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 196
iaktifsekilkare(3) = 206
durum = 1
Case 5: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 6: iaktifsekilkare(0) = 205
iaktifsekilkare(1) = 206
iaktifsekilkare(2) = 197
iaktifsekilkare(3) = 207
durum = 1
End Select
bidaha:
renk = Int(Rnd * 15) + 1
If renk = 7 Then GoTo bidaha
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End Sub
Private Sub timer1_timer()
devamet = False
For i = 0 To 3
devam(i) = False
Next
If Shape1(iaktifsekilkare(0) - 10).Visible = False Then devam(0) = True
If (iaktifsekilkare(1) - 10 = iaktifsekilkare(0)) Then
devam(1) = True
Else
If Shape1(iaktifsekilkare(1) - 10).Visible = False Then
devam(1) = True
End If
If (iaktifsekilkare(2) - 10 = iaktifsekilkare(1)) Then
devam(2) = True
Else
If Shape1(iaktifsekilkare(2) - 10).Visible = False Then
devam(2) = True
End If
If (iaktifsekilkare(3) - 10 = iaktifsekilkare(2)) Then
devam(3) = True
Else
If Shape1(iaktifsekilkare(3) - 10).Visible = False Then
devam(3) = True
End If
For i = 0 To 3
If devam(i) = True Then
devamet = True
Else
devamet = False
GoTo devamdevam
End If
Next
devamdevam:
If devamet = True Then
For i = 0 To 3
On Error Resume Next
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) - 10
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
Else
Call kontrol
Call sekilsec
End If
End Sub
Private Sub kontrol()
sil(11) = False
basla:
level = Int(puan / 1500)
Select Case level
Case 0: Timer1.Interval = 1000
Case 1: Timer1.Interval = 1000
Case 2: Timer1.Interval = 500
Case 3: Timer1.Interval = 250
Case 4: Timer1.Interval = 125
Case 5: Timer1.Interval = 60
Case 6: Timer1.Interval = 30
Case 7: Timer1.Interval = 15
Case 8: Timer1.Interval = 10
End Select
If level > 8 Then Timer1.Interval = 5
Label1.Caption = "level" & level
For i = 1 To 19
For r = 1 To 10
If Shape1(i * 10 + r).Visible = True Then
sil(r) = True
Else
sil(r) = False
End If
Next
For r = 1 To 10
If sil(r) = True Then
sil(11) = True
Else
sil(11) = False
GoTo silelim
End If
Next
silelim:
If sil(11) = True Then GoTo silbakalim
Next
Exit Sub
silbakalim:
puan = puan + 100
Label2.Caption = "puanınız:" & puan
For s = i To 19
For r = 1 To 10
If Shape1(s * 10 + r + 10).Visible = True Then
Shape1(s * 10 + r).BackColor = Shape1(s * 10 + r + 10).BackColor
Else
Shape1(s * 10 + r).Visible = False
End If
Next
Next
GoTo basla
End Sub
19-04-2006, 17:03
#9 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Sayiniz tekmi çiftmi
Kod:
command1_clik
x=val (text1.text)
if x mod 2= 0 then
list2.addlitam x
else
list1.addlitem x
end if
text1.text=""
end sub
command2_cilik
list1.clear
list2.clear
Mouse move ile ilgili bir örnek
Kod:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Select Case Picture1.Align
Case 1
If Y < 50 Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 2
If Y > (Me.Height - 50) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 3
If X < 50 Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 4
If X > (Me.Width - 50) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case Else
If Y > (Picture1.Top) And Y < (Picture1.Top + Picture1.Height) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
End Select
End Sub
Hesap makinesi
Kod:
Dim sonuc, durum, durum2, durum3, islem, adet
Private Sub hafiza(durum)
Static sayi, toplam
Select Case durum
Case 1: toplam = toplam + sayi
Case 2: sayi = Val(Giris)
Case 3: Giris = Str(Giris) + Str(sayi)
Case 4: sayi = 0
End Select
End Sub
Private Sub Btn0_Click()
Giris = Giris + "0"
End Sub
Private Sub Btn1_Click()
If durum = 0 Or durum3 = 0 Then
Giris = "1"
Else
Giris = Giris + "1"
End If
durum = 1
durum3 = 1
adet = 0
End Sub
Private Sub Btn2_Click()
If durum = 0 Or durum
Canlı yayını dinlemek için bilgisayarınızda WINAMP kurulu olmalıdır.WINAMP indirmek için TIKLAYINIZ
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
Visual Basic içinde Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir) konusu , Evet arkadaşlar hiçbir forum sitesinde bulamazsınız bu kodları bir arada..Sürekli güncellenecektir..***TNSEZER***
Güzel bir ekran koruyucu
Kod:
Dim a As Long
Private Sub Timer1_Timer()
Line (800, 800)-(800, 800 + a), Int(Rnd ...
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
KAYIT OL
Yönetim Takımı
Üye Listesi
Tüm konuları okunmuş kabul et
19-04-2006, 16:37
#1 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
Evet arkadaşlar hiçbir forum sitesinde bulamazsınız bu kodları bir arada..Sürekli güncellenecektir..***TNSEZER***
Güzel bir ekran koruyucu
Kod:
Dim a As Long
Private Sub Timer1_Timer()
Line (800, 800)-(800, 800 + a), Int(Rnd * 65000)
Line (2000, 800)-(2000, 800 + a), Int(Rnd * 65000)
Line (3000, 800)-(3000, 800 + a), Int(Rnd * 65000)
Line (4000, 800)-(4000, 800 + a), Int(Rnd * 65000)
Line (5000, 800)-(5000, 800 + a), Int(Rnd * 65000)
Line (6000, 800)-(6000, 800 + a), Int(Rnd * 65000)
Line (7000, 800)-(7000, 800 + a), Int(Rnd * 65000)
Line (8000, 800)-(8000, 800 + a), Int(Rnd * 65000)
Line (9000, 800)-(9000, 800 + a), Int(Rnd * 65000)
Line (10000, 800)-(10000, 800 + a), Int(Rnd * 65000)
Line (11000, 800)-(11000, 800 + a), Int(Rnd * 65000)
Line (12000, 800)-(12000, 800 + a), Int(Rnd * 65000)
Line (13000, 800)-(13000, 800 + a), Int(Rnd * 65000)
Line (14000, 800)-(14000, 800 + a), Int(Rnd * 65000)
Line (15000, 800)-(15000, 800 + a), Int(Rnd * 65000)
Line (800, 800)-(800 + a, 800), Int(Rnd * 65000)
Line (800, 2000)-(800 + a, 2000), Int(Rnd * 65000)
Line (800, 3000)-(800 + a, 3000), Int(Rnd * 65000)
Line (800, 4000)-(800 + a, 4000), Int(Rnd * 65000)
Line (800, 5000)-(800 + a, 5000), Int(Rnd * 65000)
Line (800, 6000)-(800 + a, 6000), Int(Rnd * 65000)
Line (800, 7000)-(800 + a, 7000), Int(Rnd * 65000)
Line (800, 8000)-(800 + a, 8000), Int(Rnd * 65000)
Line (800, 9000)-(800 + a, 9000), Int(Rnd * 65000)
Line (800, 10000)-(800 + a, 10000), Int(Rnd * 65000)
Line (800, 11000)-(800 + a, 11000), Int(Rnd * 65000)
a = a + 50
End Sub
Yazi tipi uygulamasi
Kod:
Private Sub Check4_Click()
If Check4.Value = 1 Then
Check5.Value = 0
Text1.ForeColor = RGB(255, 0, 0)
End If
End Sub
Private Sub Check5_Click()
If Check5.Value = 1 Then
Check4.Value = 0
Text1.ForeColor = RGB(0, 255, 0)
End If
End Sub
Private Sub Check6_Click()
If Check4.Value = 1 Then
Check5.Value = 0
Text1.ForeColor = RGB(255, 0, 255)
End If
End Sub
Private Sub Command1_Click()
If Check1.Value = 1 Then
Text1.FontBold = True
Else
Text1.FontBold = False
End If
If Check2.Value = 1 Then
Text1.FontItalic = True
Else
Text1.FontItalic = False
End If
If Check3.Value = 1 Then
Text1.FontUnderline = True
Else
Text1.FontUnderline = False
End If
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
Text1.FontSize = Text1.FontSize - 5
End Sub
Private Sub Command4_Click()
Text1.FontSize = Text1.FontSize + 5
End Sub
Vscrollbar ile fomda arka plan rengi ayarlama
Kod:
Private Sub VScroll1_Change()
Form1.BackColor = _
RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub
Private Sub VScroll2_Change()
Form1.BackColor = _
RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub
Private Sub VScroll3_Change()
Form1.BackColor = _
RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub
19-04-2006, 16:40
#2 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Sayi bulma oyunu
Alt Alta 5 Tane Text Box Açyn ve 2 Tane de Command Buton Ekleyin...
Kod:
dim tes as integer
dim st as integer
dim sakla as integer
dim uyary as string
dim i as integer
________________________________
Private Sub Form_Load()
End Sub
________________________________
Private Sub Command1_Click()
tes = Text1.text
sakla = tes
Text4.text =sakla
Text1.text=""
End Sub
________________________________
Private Sub Command2_Click()
tes =Text1.text
st =Text2.text
If st = sakla Then
i = i + 1
uyary="Tebrikler i denemede bildiniz!"
Text5.text = i
End If
If st < sakla Then
i = i + 1
Text2.text = ""
uyary="Tahmininiz Küçük!"
Text5.text = i
End If
If st > sakla Then
i = i + 1
Text2.text = ""
uyary="Tahmininiz Büyük!"
Text5.text = i
End If
Text3.text = uyary
End Sub
Hesap makinasi
Kod:
Dim a As Double
Dim b As Double
Private Sub Command1_Click()
Label1.Caption = a & "1"
a = Label1.Caption
If a = 1 Then
Label1.Caption = "1"
End If
End Sub
Private Sub Command2_Click()
Label1.Caption = a & "2"
a = Label1.Caption
If a = 2 Then
Label1.Caption = "2"
End If
End Sub
Private Sub Command3_Click()
Label1.Caption = a & "3"
a = Label1.Caption
If a = 3 Then
Label1.Caption = "3"
End If
End Sub
Private Sub Command4_Click()
Label3.Caption = Val(a) + Val(b)
End Sub
Private Sub Command5_Click()
Label3.Caption = Val(a) * Val(b)
End Sub
Private Sub Command6_Click()
Label2.Caption = b & "1"
b = Label2.Caption
If b = 1 Then
Label2.Caption = "1"
End If
End Sub
Private Sub Command7_Click()
Label2.Caption = b & "2"
b = Label2.Caption
If b = 2 Then
Label2.Caption = "2"
End If
End Sub
Private Sub Command8_Click()
Label2.Caption = b & "3"
b = Label2.Caption
If b = 3 Then
Label2.Caption = "3"
End If
End Sub
List kutusunu access veritabanina baglamak
forma bi tane data nesnesi bi tane de list kutusu ekleyin.
Kod:
Private Sub Form_Activate()
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List1.AddItem (Data1.Recordset![mallar])
Data1.Recordset.MoveNext
Loop
End Sub
Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_stok"
End Sub
19-04-2006, 16:44
#3 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Bilgisayarin sesini açip kisabilirsiniz
1- Forma 1 tane modül, 6 tane label, 2 tane timer, 1 tane check kutusu, 2 tane slider kontrolü(MSCOMCTL.OCX) ekleyin.
''''''''''''''''''''''''''''Modüle eklenecek kisim''''''''''''''''''''''''''''
Kod:
Public Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long
Public Declare Function waveOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
Public Const MAXPNAMELEN = 32 ' max product name length (including NULL)
Public Type WAVEOUTCAPS
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
dwFormats As Long
wChannels As Integer
dwSupport As Long
End Type
Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Public Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long
''''''''''''''''''''''''''''''''''Forma eklenecek kisim'''''''''''''''''''''''''''''''''''''''
Kod:
Private Sub Check1_Click()
Timer1.Interval = 0
Timer2.Interval = 0
End Sub
Private Sub Form_Load()
label1.caption="sag"
label2.caption="sol"
label3.caption="alçak"
label4.caption="yüksek"
label5.caption="alçak"
label6.caption="yüksek"
check1.caption="Kaydirma Göstergeleri Ayni Anda Hareket Etsin"
Dim lpc As WAVEOUTCAPS
If waveOutGetNumDevs() = 0 Then
MsgBox ("Ses çalacak donanmim yok")
End If
Call waveOutGetDevCaps(0, lpc, Len(lpc))
If lpc.wChannels = 0 Then
Slider2.Visible = False [m]'mono ise birini gizle[/m]
End If
If (lpc.dwSupport And 4) = 0 Then [m]'ses ayarini desteklemiyorsa ikisinide gizle[/m]
Slider1.Visible = False
Slider2.Visible = False
End If
If (lpc.dwSupport And 8) = 0 Then [m]'sol sag ses ayarini desteklemiyorsa birini gizle[/m]
Slider2.Visible = False
End If
Slider1.Min = 0
Slider1.Max = &HFFFF&
Slider1.TickFrequency = &HFFFF& / 10
Slider2.Min = 0
Slider2.Max = &HFFFF&
Slider2.TickFrequency = &HFFFF& / 10
Dim x, sol, sag, st [m]'su anki seviyeyi göster[/m]
Call waveOutGetVolume(0, x)
sol = x And &HFFFF& [m]'düsük seviyeli 2byte[/m]
st = Hex(x And &HFFFF0000)
If Len(st) > 4 Then
st = Mid(st, 1, Len(st) - 4) [m]'yüksek seviyeli 2 bayti al[/m]
Else
st = 0
End If
sag = CDbl("&h" & st)
Slider1.Value = sol
Slider2.Value = sag
End Sub
Sub sesayar()
Dim x, sol, sag, s
sol = Slider1.Value
sag = Slider2.Value
s = Val("&h" & Hex(sag) & String(4 - Len(Hex(sol)), "0") & Hex(sol) & "&")
Call waveOutSetVolume(0, s)
End Sub
Private Sub Slider1_Click()
sesayar
End Sub
Private Sub Slider1_Scroll()
If Check1.Value = 0 Then
Else
Timer1.Interval = 0
Timer2.Interval = 1
End If
sesayar
End Sub
Private Sub Slider2_Click()
sesayar
End Sub
Private Sub Slider2_Scroll()
If Check1.Value = 0 Then
Else
Timer2.Interval = 0
Timer1.Interval = 1
End If
sesayar
End Sub
Private Sub Timer1_Timer()
Slider1 = Slider2
End Sub
Private Sub Timer2_Timer()
Slider2 = Slider1
End Sub
Ek kontrollerin bulunduklari .ocx dosyalari
PictureBox, Label, TextBox, Image, ListBox, Combobox, OptionButton, CheckBox, ScrollBar, Frame, Timer, DriveListbox, DirectoryListBox, FileListBox, Shape, Line, Data Kontrolleri herhangi bir dosyaya ihtiyaç duymaksizin araççubugundaki (toolbox) yerini alir. Ancak diger kontrolleri kullanabilmek için o kontrollerin bulundugu OCX dosyasini Vb'ye eklemek gerekir.
Asagidaki tabloda Hangi OCX dosyasinda hangi kontrollerin bulundugu gösteriliyor. Bu Controllerden birini kullanabilmek için "Project" / "Components" menülerini takip edip Listeden seçebilirsiniz, Eger listede yoksa "Browse" dügmesine basin ve dosyayi bulup seçin.
Component Adi Dosya Adi Kontroller
Kod:
Microsoft(MS) ADO Data Cont. 6.0 MSADODC.OCX ADO Data Control
MS Chart Control 5.5 MSCHART.OCX Microsoft Chart
MS Comm Control 6.0 MSCOMM32.OCX MSComm
MS Common Dialog Control 6.0 COMDLG32:OCX Common Dialog
MS Data Bound Grid Control 5.0 DBGRID32.OCX DBGrid
MS Data Bound List Controls 6.0 DBLIST32.OCX DBList, DBCombo
MS Data Repeater Control 6.0 MSDATREP.OCX DataRepeater
MS Data Grid Control 6.0 MSDATGRD.OCX DataGrid
MS Data List Controls 6.0 MSDATLST.OCX DataList, DataCombo
MS FlexGrid Control 6.0 MSFLXGRD.OCX MsFlexGrid
MS Grid Control GRID32.OCX Grid
MS Hierarchical Flex Grid Control 6.0 MSHFLXGD.OCX MSHFlexGrid
MS Internet Transfer Control 6.0 MSINET.OCX Inet
MS MAPI Controls 6.0 MSMAPI32.OCX MapiMessages, MAPISession
MS MaskedEdit Control 6.0 MSMASKE32.OCX MaskedEdit
MS Multimedia Control 6.0 MCI32.OCX Multimedia MCI
MS PictureClip Control 6.0 PICCLP32.OCX PictureClip
MS RemoteData Control 6.0 MSRDC20.OCX RemoteData
MS RichTextBox Control 6.0 RICHTX.OCX RichTextBox
MS SysInfo Conterol 6.0 SYSINFO.OCX SysInfo
MS TabbedDialog Control 6.0 TABCTL32.OCX Ms Tab Control
MS Windows Common Controls 6.0 MSCOMCTL.OCX TabStrip, Toolbar, StatusBar,
ProgressBar, TreeView, ListView,
ImageList, Slider, ImageCombo
MS WIndows Common Controls-2 6.0 MSCOMCTL2.OCX Animation, UpDown, MonthView,
DTPicker, FlatScrollbar
MS Windows Common Controls-3 6.0 MSCOMCTL3.OCX CoolBar
MS Winsock Control 6.0 MSWINSOCK.OCX Winsock
Bagzen Programinizi Baska Bir Bilgisayarda çalistirmak istediginizde MSCOMCTL.OCX dosyasinin bilgisayarda olmadigi ve gerektigi Hatasi verir. Iste programlarininzda kullandiginiz kontrollere göre .OCX dosyalarini da Setupa, yada Programiniza dahil ederseniz, Bu tip sorunlar olmaz.
19-04-2006, 16:47
#4 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Program yaziyosaniz lazimdir
1_ Visual Basic Service Pack 6.0 (vb'nin sp 6 güncellestirmesidir.)
http://www.microsoft.com/downloads/i...82/Vs6sp6B.exe
2_ Visual Basic Runtime 6.0 (vb'nin çalisma dosyalaridir)
http://download.microsoft.com/downlo...vbrun60sp3.EXE
3_ Microsoft Data Access Component (MDAC) 2.5 (veritabani uygulamasi olan programlar için access yamasidir)
http://www.microsoft.com/downloads/i...S/MDAC_TYP.EXE
4_ Visual Basic Kod Bankasi 1.7 (Tam 2081 adet vb kodu içerir)
http://www.sezginweb.com/programlar/vbkodbank17.exe
5_ Setup Pro (Türkçe bir setup hazrlama programidir)
http://www.sezginweb.com/programlar/setuppro.rar
6_ Cyrstal Reports 10 (vb üzerinde raporlama yapmak isteyenler için)
http://ftp.crystaldecisions.com/outg.../CR10DevEn.exe
7_ 1000 adet hazir icon (programinizda kullanabileceginiz 100 adet hazir icon bu dosyanin içinde)
http://www.vbasicmaster.com/zips/icons.zip
8_ Help Creator (vb'de yardim(help) dosyalari hazirlayabilirsiniz.)
http://www.breittechnologies.com/pro...torInstall.exe
9_ API-Guide V 3.7.854 (Apilerle ilgili birçok bilgi içeriyor)
http://www.student.kuleuven.ac.be/~m....7/agsetup.exe
Forma media playeri çagirma
Kod:
Private Sub Command11_Click()
Call Shell("C:\Program Files\Windows Media Player\wmplayer.exe /prefetch:1.exe", 1)
End Sub
Dosyanin tam yolunu yazmak zorunda degilsiniz
Kod:
Private Sub Form_Load()
Dim Path As String
Path = "c:\windows\media\tada.wav"
MsgBox Path
Path = StrReverse(Split(StrReverse(Path), "\")(0))
MsgBox Path
End Sub
19-04-2006, 16:51
#5 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Internetteki access veritabanindaki kayit sayisi
Project/Components'ten
Microsoft Internet Transfer Control
Microsoft Ado Data Control
Microsoft Datagrid Control
projenize eklyin
1 adet label ve 1 adet command ekleyin
kodlari oldugu gibi forma yapistirin
Kod:
Private Sub Command1_Click()
Label1.Caption = "Veritabaninda toplam " & Adodc1.Recordset.RecordCount & " kayit var"
End Sub
Private Sub Form_Load()
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=\\www.sezginweb.com\deneme\kayit.mdb"
Adodc1.RecordSource = "tblogrenciler"
Set DataGrid1.DataSource = Adodc1
End Sub
Her türlü müzik dosyasini çalma
project componentten microsoft common dialog control ü ekleyin
4 command 1 tanede text kutusu ekleyin
olduğu gibi forma yapıştırn
Kod:
Private 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
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Sub Command1_Click()
Dim Hata As Long
Dim HataMesaji As String * 128
'Mesajı gönderiyoruz
Hata = mciSendString("open " & Chr$(34) & Text1.Text & Chr$(34) & " alias YeniSes", 0, 0, 0)
'Hata Mesajını Alıyoruz
mciGetErrorString Hata, HataMesaji, 128
MsgBox HataMesaji
End Sub
Private Sub Command2_Click()
mciSendString "play YeniSes", 0, 0, 0
End Sub
Private Sub Command3_Click()
mciSendString "close Yenises", 0, 0, 0
End Sub
Private Sub Command4_Click()
On Error GoTo error
With CommonDialog1
.CancelError = True
.DialogTitle = "Ses Dosyası aç_-_-_-_-Sunasoft Yazılım Bilgisayar-_-_-_-_"
.Filter = "Şarkı Dosyaları (*.mp3) |*.mp3; |Ses Dosyaları (*.wav) |*.wav; |Midi Dosyaları (*.mid) |*.mid"
.InitDir = "c:\"
.ShowOpen
If Len(.FileName) = 0 Then Exit Sub
Text1.Text = .FileName
cmdPlay.SetFocus
End With
error:
End Sub
Private Sub Form_Load()
'''Buraları bilmesenizde olur ben sadece nasıl çalıştığını görün diya yaptım
Left = (Screen.Width - Width) \ 2
Top = (Screen.Height - Height) \ 2
Command1.Caption = "Yükle"
Command2.Caption = "Çal"
Command3.Caption = "Dur"
Command4.Caption = "Gözat"
Form1.Height = 4920
Form1.Width = 8820
Command1.Top = 720
Command1.Left = 480
Command2.Top = 1320
Command2.Left = 480
Command3.Top = 1920
Command3.Left = 480
Command4.Top = 2400
Command4.Left = 6600
Text1.Top = 2520
Text1.Left = 480
Text1.Height = 285
Text1.Width = 6015
End Sub
Vb üzerinden excelde arama yapmak
Project/References menülerinden "Microsoft Excel 10.0 Object Library" ekleyin,
Formunuza 9 adet text kutusu, 9 adet label ve bir adet command butonu ekleyin,
ve aşağıdaki kodları olduğu gibi forma yapıştırın ve çalıştırın.
Kod:
Dim c As Excel.Range
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Sub ExcelAra()
On Error GoTo hata
Set xlApp = New Excel.Application
Text2.Text = ""
Set xlBook = Workbooks.Open(App.Path & "\devlet_kurumlari.xls", , True)
Set xlSheet = xlBook.Worksheets("sheet 1")
With xlSheet.Range("a1:c65536")
Set c = .Find(Trim(Text1.Text), lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Text2.Text = c.Address
Range(Text2.Text).Select
Text3.Text = Excel.ActiveCell.Row
'??????_______Kurum Adı
Range("$d$" & Text3.Text).Select
Text4.Text = Excel.ActiveCell
'??????_______Kurum İli
Range("$a$" & Text3.Text).Select
Text5.Text = Excel.ActiveCell
'??????_______Kurum İlçesi
Range("$b$" & Text3.Text).Select
Text6.Text = Excel.ActiveCell
'??????_______Kurum Telefonu
Range("$e$" & Text3.Text).Select
Text7.Text = Excel.ActiveCell
MaskEdBox1.Text = Excel.ActiveCell
'??????_______Kurum Fax
Range("$f$" & Text3.Text).Select
Text8.Text = Excel.ActiveCell
'??????_______Kurum Adres
Range("$g$" & Text3.Text).Select
Text9.Text = Excel.ActiveCell
Do
c.Interior.Pattern = xlPatternGray50
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
If Text2.Text = "" Then Text2.Text = "Bulunamadı..."
xlBook.Close False
xlApp.Quit
Exit Sub
hata:
MsgBox Err.Description
End Sub
Private Sub Command1_Click()
ExcelAra
End Sub
19-04-2006, 16:55
#6 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Bilgisayar her açildiginda program çalissin mi çalismasin mi?
Forma bi tane checkbox, bi tane label, bitane textbox, bitane de data nesnesi koyun.
bi tane veritabanı oluşturun(access) adınıda sabit.mdb yapın.bu veritabanında bi tane tablo oluşturun adını tbl_kontrol yapın.Bu tabloda bi tane alan oluşturun adını da windows_acilis yapın.
text1 nesnesi data1'e bağlayın.
label'in captionuna "Bilgisayar her açıldığında program çalışsın" yazın.
Bu veritabanı programınızla aynı klasörde olsun.
'''''''''''''''''''''''''''''BİTTİ'''''''''''''''' ''''''''''''''''''''''''''''''
Kod:
Private Sub Check1_Click()
If Check1.Value = 0 Then
Text1.Text = "1"
End If
If Check1.Value = 1 Then
Text1.Text = "2"
End If
Dim KayitDefteri As Object
Set KayitDefteri = CreateObject("wscript.shell")
If Text1.Text = "1" Then
KayitDefteri.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN\" & App.EXEName, "" & "" & "" & ""
End If
If Text1.Text = "2" Then
KayitDefteri.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
End If
End Sub
Private Sub Form_Activate()
If Text1.Text = "1" Then
Check1.Value = 0
End If
If Text1.Text = "2" Then
Check1.Value = 1
End If
End Sub
Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_kontrol"
Text1.DataField = "windows_acilis"
End Sub
Winampa benziyor
İlk Yapılacaklar :
1- Bi tane veritabanı oluşturun, adı sabit.mdb olsun.
2- Bu veritabanında bi tane tablo oluşturun adı tbl_muzikyayini olsun.
3- Bu tabloyada iki tane alan yerleştirin, biri zil_müzikler_toplanmis diğeri zil_müzikler_acilmis olsun.
4- Sonra forma; 2 list kutusu, 4 text kutusu, 1 comman button, 1 data nesnesi, 2 timer, 1 tanede commondialog control ekleyin.
5- Commanbuttonun captionuna ekle yazın.
6- Timerlerin interval özelliğini 1 yapın.
Açıklama :
1- Commandbutonun captionuna ekle yazın, bununla belirttiğimiz bir klasörden müzik dosyasını list2'ye akatarıcaz.list2'de dosyanın tam yolu yazacağı için, ordan list1'e sadece müzik dosyasının adı gelecek.
2- Text4 ile müziğin şu an çalıp çalmadığını kontrol edicez, çalıyosa playing yazacak, çalmıyorsa stoping yazacak.
3- Timer2 ile durumu kontrol edicez müzik dosyası çalıyomu çalmıyomu, buna göre bir sonraki müzik dosyasını çaldırtıcaz.
4- Timer1 ile de duruma göre bir sonraki müzik dosyasını çaldırıcaz.
5- Text3 ile çalınan müzik dosyasının uzunluğunu dakika cinsinden göstericez.
VEEEE AŞAĞIDAKİ KODLARI OLDUĞU GİBİ FORMA YAPIŞTIRICAZ
Kod:
Private 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
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Function StripPath(T$) As String '''''''Dosyanın kısa adını gösteren kod
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
ct% = x%
x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
Private Sub Command1_Click() '''''Projemize müzik dosyası buradan ekleniyor
On Error Resume Next
Data1.Recordset.AddNew
Data2.Recordset.AddNew
With CommonDialog1
'On Cancel do nothing
.CancelError = True
.DialogTitle = "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\Sunasoft Yazılım///////////////////////////////////"
.Filter = "Hepsi ( *.mp3 *.wav *.mid ) |*.mp3;*.wav;*.mid|Şarkı Dosyaları (*.mp3) |*.mp3; |Ses Dosyaları (*.wav) |*.wav; |Midi Dosyaları (*.mid) |*.mid"
.InitDir = App.Path & "\müzikler\"
.ShowOpen
'Handle no filename
If Len(.FileName) = 0 Then Exit Sub
Text1.Text = .FileName
List1.AddItem Text1.Text
file = StripPath(Text1.Text)
Text2.Text = file
List2.AddItem file
List1.Clear
List2.Clear
Form_Activate
End With
error: 'Do nothing
End Sub
Private Sub Form_Activate() '''Burada list kutusunu veritabanına bağlıyoruz
On Error Resume Next
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List1.AddItem (Data1.Recordset![zil_müzikler_acilmis])
Data1.Recordset.MoveNext
Loop
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List2.AddItem (Data1.Recordset![zil_müzikler_toplanmis])
Data1.Recordset.MoveNext
Loop
End Sub
Private Sub Form_Load() ''''Data nesenesine bağlantı ayarları buradan yapılıyor
mciSendString "close Yenises", 0, 0, 0 'Müzik dosyasını kapat
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_muzikyayini"
End Sub
Private Sub Form_Unload(Cancel As Integer) '''Çıkarken çalan müziği kapatıyoruz
mciSendString "close Yenises", 0, 0, 0
End Sub
Private Sub List2_Click() ''''List2'de tıklanan müziği çaldırtıyoruz
On Error Resume Next
Dim i
For i = 0 To List2.ListCount - 1
If List2.Selected(i) Then
mciSendString "close Yenises", 0, 0, 0
Hata = mciSendString("open " & Chr$(34) & List2.List(i) & Chr$(34) & " alias YeniSes", 0, 0, 0)
mciSendString "play YeniSes", 0, 0, 0 'Müziği oynatma kısmı
Dim Dondur As String * 128 '''Burada adı geçen dondur=çalmasüresidir
mciSendString "status YeniSes length", Dondur, 128, 0
Text3.Text = ((Dondur / 60000))
End If
Next
End Sub
Private Sub Timer1_Timer()
If Text4.Text = "stopped" Then 'Eğer müzik dosyası çalmıyorsa demek oluyo.
If List2.ListIndex = List2.ListCount - 1 Then '''Eğer listenin sonuna gelinmişşe
List2.Selected(0) = True '''Listenin en başındakini seç
Else 'Gelmemişse daha o zaman alttaki koddan devam et
List2.Selected(List2.ListIndex + 1) = True ''Bir önceki dosyadan sonrakini çalmaya devam et
End If
For i = 0 To List2.ListCount - 1
If List2.Selected(i) Then
mciSendString "close Yenises", 0, 0, 0
Hata = mciSendString("open " & Chr$(34) & List2.List(i) & Chr$(34) & " alias YeniSes", 0, 0, 0)
mciSendString "play YeniSes", 0, 0, 0
Dim Dondur As String * 128
mciSendString "status YeniSes length", Dondur, 128, 0
Text3.Text = ((Dondur / 60000))
End If
Next
End If
End Sub
Private Sub Timer2_Timer() '''Durumu sürekli olarak kontrol et
Dim Durum As String * 128
mciSendString "status YeniSes mode", Durum, 128, 0
Text4.Text = Durum
End Sub
Araba yarisi
Evet Arkadaşlar merhaba şimdi sizinle araba yarışı yapacagız
Araçlar : 1) iki tane Shape ekliyoruz bunlar araba olucak bu Shape adını Shape1 ve Shape2 yapıyoruz.
2) Timer ekliyoruz Left 5280 Top 3120 olarak değiştiriyoruz.
3) Command buton ekliyoruz
Aşağıda vermiş olduğum kodu ekliyoruz bu kadar.
Kod:
Private Sub Command1_Click()
Timer1.Interval = 10
Timer2.Interval = 10
End Sub
Private Sub Form_Load()
End Sub
Private Sub Timer1_Timer()
Randomize
g = Rnd(100) * 100
Shape1.Move Shape1.Left + g
If Shape1.Left >= 8000 Then
MsgBox ("kazanan pembe araba")
End
End If
End Sub
Private Sub Timer2_Timer()
Randomize
f = Rnd(100) * 100
Shape2.Move Shape2.Left + f
If Shape2.Left >= 8000 Then
MsgBox ("kazanan beyaz araba")
End
End If
End Sub
19-04-2006, 16:57
#7 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Oyun yasin
' 2 adet timer 1 label 1 pictrue box ve bir tane command tuşu form da bulunması gerekenlerdendir
Dim satirsayisi, sutunsayisi, kutusayisi, puan
Kod:
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.Left = Command1.Left + 100
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyLeft: Command1.Left = Command1.Left - 15
Case vbKeyRight: Command1.Left = Command1.Left + 15
If Command1.Left >= Form1.ScaleWidth - Command1.Width Then
Command1.Left = Form1.ScaleWidth - Command1.Width
End If
End Select
End Sub
Private Sub Form_Load()
Caption = "yasin çakmak"
Dim i, j, k
Show
ScaleMode = 3 'pixel
KeyPreview = True
satirsayisi = 5
sutunsayisi = 10
kutusayisi = satirsayi * sutunsayisi
Timer1.Interval = 10
Timer2.Interval = 10
Command1.Top = ScaleHeight - Label1.Height
Label1 = "0 "
Shape1.Shape = 3
Shape1.FillStyle = 7
Shape1.Width = 18
Shape1.Height = 18
Picture1(0).Width = 60
Picture1(0).Height = 20
widh = Picture1(0).Width * sutunsayisi * Screen.TwipsPerPixelX + 30
Picture1(0).Move 0, 0
Picture1(0).BackColor = QBColor(1)
For i = 1 To satirsayisi
For j = 1 To sutunsayisi
k = k + 1
Load Picture1(k)
Picture1(k).Left = Picture1(k - 1).Left + Picture1(k).Width
Picture1(k).Top = (i - 1) * Picture1(k).Height
Picture1(k).Visible = True
Picture1(k).BackColor = QBColor(i)
Next
Picture1(k).Left = 0
Next
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.Left = X
End Sub
Private Sub Timer1_Timer()
Static xa, ya
If IsEmpty(xa) Then xa = 10: ya = 10
If Shape1.Left <= 0 Then xa = -xa
If Shape1.Left >= ScaleWidth Then xa = -xa
If Shape1.Top < 0 Then ya = -ya
If (Shape1.Top >= Command1.Top) And (Shape1.Top < (Command1.Top + Command1.Height)) And Shape1.Left > Command1.Left And Shape1.Left < (Command1.Left + Command1.Width) Then ya = -ya
If Shape1.Top >= ScaleHeight Then
MsgBox "oyun bitti"
Timer1.Interval = False
End
End If
Dim i, j, k
k = -1
For i = 1 To sutunsayisi
For j = 1 To satirsayisi
k = k + 1
If Picture1(k).Visible = True And Shape1.Left >= Picture1(k).Left And Shape1.Left < (Picture1(k).Left + Picture1(k).Width) And Shape1.Top <= (Picture1(k).Top + Picture1(k).Height) Then
Picture1(k).Visible = False
kutusayisi = kutusayisi - 1
ya = -ya
puan = puan + 100
Label1 = puan
End If
Next
Next
Shape1.Left = Shape1.Left + xa
Shape1.Top = Shape1.Top + ya
If kutusayisi = 1 Then
MsgBox ("tebrikler")
End If
End Sub
Private Sub Timer2_Timer()
Picture1(Rnd * (satirsayisi * sutunsayisi - 1)).BackColor = QBColor(Rnd * 15)
End Sub
Yanip sönen buton
Kod:
Private Sub Timer1_timer
command1.backgroundcolor = ffff00
Command1.backgroundcolor=0f0f
end sub
Basit bir kronometre
Kod:
Private Sub basla_Click()
Timer1.Enabled = True
Timer1.Interval = 1000
End Sub
Private Sub durudur_Click()
Timer1.Enabled = False
Label8.Caption = saat
Label9.Caption = dakika
Label10.Caption = saniye
End Sub
Private Sub Timer1_Timer()
Label3.Caption = Now
saniye = saniye + 1
If saniye = 59 Then
dakika = dakika + 1
saniye = 0
End If
If dakika = 59 Then
saat = saat + 1
dakika = 0
End If
Label4.Caption = saat
Label5.Caption = dakika
Label6.Caption = saniye
End Sub
19-04-2006, 17:00
#8 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Ethernet kartinin mac adresini alma
Kod:
Private Const NCBASTAT As Long = &H33
Private Const NCBNAMSZ As Long = 16
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private Const HEAP_GENERATE_EXCEPTIONS As Long = &H4
Private Const NCBRESET As Long = &H32
Private Type NET_CONTROL_BLOCK
ncb_command As Byte
ncb_retcode As Byte
ncb_lsn As Byte
ncb_num As Byte
ncb_buffer As Long
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte
ncb_sto As Byte
ncb_post As Long
ncb_lana_num As Byte
ncb_cmd_cplt As Byte
ncb_reserve(9) As Byte
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(5) As Byte
rev_major As Byte
reserved0 As Byte
adapter_type As Byte
rev_minor As Byte
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NET_CONTROL_BLOCK) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Function GetMACAddress() As String
Dim tmp As String
Dim pASTAT As Long
Dim NCB As NET_CONTROL_BLOCK
Dim AST As ASTAT
NCB.ncb_command = NCBRESET
Call Netbios(NCB)
NCB.ncb_callname = "* "
NCB.ncb_command = NCBASTAT
NCB.ncb_lana_num = 0
NCB.ncb_length = Len(AST)
pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, NCB.ncb_length)
If pASTAT = 0 Then
Debug.Print "memory allocation failed!"
Exit Function
End If
NCB.ncb_buffer = pASTAT
Call Netbios(NCB)
CopyMemory AST, NCB.ncb_buffer, Len(AST)
tmp = Format$(Hex(AST.adapt.adapter_address(0)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(1)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(2)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(3)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(4)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(5)), "00")
HeapFree GetProcessHeap(), 0, pASTAT
GetMACAddress = tmp
End Function
Private Sub Form_Load()
MsgBox "Ethernet kartının MAC adresi: " + GetMACAddress()
End Sub
Basit bir screen saver
Kod:
Declare Function ShowCursor Lib "user32" (ByVal fShow As Integer) As Integer
Global maxLines As Integer
Sub endScrnSave()
showmouse
End
End Sub
Sub HideMouse()
While ShowCursor(False) >= 0
Wend
End Sub
Sub main()
BlankForm.Show
End Sub
Sub showmouse()
While ShowCursor(True) < 0
Wend
End Sub
'Formuna bir tane timer ekle interval=100 yap
'Formun özelliklerini border style=none yap
'Formun backcolor'unu siyah yap ve aşağıdaki kodu pastele.
'exe file yaparkende exe yi scr olarak değiştir windows\ system yapıştır.
'hadi kolay gelsin. Batuge'den :)
Dim lastX, lastY
Dim numlines
Sub form_Keydown(Keycode As Integer, Shift As Integer)
endScrnSave
End Sub
Private Sub Form_Load()
Move 0, 0, Screen.Width, Screen.Height
HideMouse
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If IsEmpty(lastX) Or IsEmpty(lastY) Then
lastX = X
lastY = Y
End If
If Abs(lastX - X) > 2 Or Abs(lastY - Y) > 2 Then
endScrnSave
End If
lastX = X
lastY = Y
End Sub
Private Sub Timer1_Timer()
Dim CX, CY, Radius, Limit
ScaleMode = 3
CX = ScaleWidth / 2
CY = ScaleHeight / 2
If CX > CY Then Limit = CY Else Limit = CX
For Radius = 0 To Limit
Circle (CX, CY), Radius, RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Next Radius
End Sub
Basit tetris
Kod:
Option Explicit
Private i, k, durum, renk, r, s, level, puan
Private iaktifsekilkare(3) As Integer
Private devam(3) As Boolean
Private devamet As Boolean
Private sola(3) As Boolean
Private solagit As Boolean
Private saga(3) As Boolean
Private sagagit As Boolean
Private sil(11) As Boolean
Private Sub form_keydown(keycode As Integer, shift As Integer)
On Error Resume Next
If keycode = vbKeyLeft Then
If Not (iaktifsekilkare(0) Mod 10 = 1) Then
If Shape1(iaktifsekilkare(0) - 1).Visible = False Then
sola(0) = True
Else
sola(0) = False
End If
If (iaktifsekilkare(1) - 1 = iaktifsekilkare(0)) Then
sola(1) = True
Else
sola(1) = False
End If
End If
If ((iaktifsekilkare(2) - 1 = iaktifsekilkare(0)) Or (iaktifsekilkare(2) - 1 = iaktifsekilkare(1))) Then
sola(2) = True
Else
If Shape1(iaktifsekilkare(2) - 1).Visible = False Then
sola(2) = True
Else
sola(2) = False
End If
End If
If ((iaktifsekilkare(3) - 1 = iaktifsekilkare(0)) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(1)) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(1) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(2)))) Then
sola(3) = True
Else
If Shape1(iaktifsekilkare(3) - 1).Visible = False Then
sola(3) = True
Else
sola(3) = False
End If
End If
For i = 0 To 3
If sola(i) = True Then
solagit = True
Else
solagit = False
GoTo soladevam
End If
Next
soladevam:
If solagit = True Then
If solagit = True Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) - 1
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End If
End If
End If
If keycode = vbKeyRight Then
If Not (iaktifsekilkare(3) Mod 10 = 0) Then
If Shape1(iaktifsekilkare(3) + 1).Visible = False Then
saga(3) = True
Else
saga(3) = False
End If
If (iaktifsekilkare(2) + 1 = iaktifsekilkare(3)) Then
saga(2) = True
Else
If Shape1(iaktifsekilkare(2) + 1).Visible = False Then
saga(2) = True
Else
saga(2) = False
End If
End If
If ((iaktifsekilkare(1) + 1 = iaktifsekilkare(3)) Or (iaktifsekilkare(1) + 1 = iaktifsekilkare(2))) Then
saga(1) = True
Else
If Shape1(iaktifsekilkare(1) + 1).Visible = False Then
saga(1) = True
Else
saga(1) = False
End If
End If
If ((iaktifsekilkare(0) + 1 = iaktifsekilkare(3)) Or (iaktifsekilkare(0) + 1 = iaktifsekilkare(2)) Or (iaktifsekilkare(0) + 1 = iaktifsekilkare(1))) Then
saga(0) = True
Else
If Shape1(iaktifsekilkare(0) + 1).Visible = False Then
saga(0) = True
Else
saga(0) = False
End If
End If
For i = 0 To 3
If saga(i) = True Then
sagagit = True
Else
sagagit = False
GoTo sagadevam
End If
Next
sagadevam:
If sagagit = True Then
For i = 3 To 0 Step -1
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) + 1
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End If
End If
If keycode = vbKeyDown Then
Timer1.Enabled = False
Timer1.Interval = 10
Timer1.Enabled = True
End If
If keycode = vbKeySpace Then
Select Case k
Case 1
If durum = 1 Then
On Error Resume Next
If Shape1(iaktifsekilkare(1) - 20).Visible = False And Shape1(iaktifsekilkare(1) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1) - 20
iaktifsekilkare(1) = iaktifsekilkare(1) - 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(1) + 20
durum = 2
End If
ElseIf durum = 2 Then
On Error Resume Next
If Shape1(iaktifsekilkare(2) - 1).Visible = False And Shape1(iaktifsekilkare(2) + 1).Visible = False And Shape1(iaktifsekilkare(2) + 2).Visible = False And (Not iaktifsekilkare(2) Mod 10 = 1) And (iaktifsekilkare(2) Mod 10 < 9) And (Not (iaktifsekilkare(2) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 1
iaktifsekilkare(1) = iaktifsekilkare(2)
iaktifsekilkare(2) = iaktifsekilkare(2) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 2
If durum = 1 Then
If iaktifsekilkare(2) < 200 Then
If Shape1(iaktifsekilkare(2) + 10).Visible = False And Shape1(iaktifsekilkare(3) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(3) - 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(0) - 11).Visible = False And Shape1(iaktifsekilkare(0) - 10).Visible = False And Not (iaktifsekilkare(0) Mod 10 = 1) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 11
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 3
If durum = 1 Then
If iaktifsekilkare(2) < 200 Then
If Shape1(iaktifsekilkare(2) + 10).Visible = False And Shape1(iaktifsekilkare(0) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 10
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(2)
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(2) - 9).Visible = False And Shape1(iaktifsekilkare(2) - 10).Visible = False And Not (iaktifsekilkare(2) Mod 10 = 0) And Not (iaktifsekilkare(0) Mod 10 = 1) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1)
iaktifsekilkare(1) = iaktifsekilkare(0) - 9
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(1) + 1
durum = 1
End If
End If
Case 4
Case 5
If durum = 1 Then
If iaktifsekilkare(1) < 190 Then
If Shape1(iaktifsekilkare(1) + 10).Visible = False And Shape1(iaktifsekilkare(1) + 20).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(0) + 1
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(3) + 10).Visible = False And Shape1(iaktifsekilkare(0) - 1).Visible = False And (Not (iaktifsekilkare(0) Mod 10 < 2)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 3
End If
ElseIf durum = 3 Then
If Shape1(iaktifsekilkare(2) - 10).Visible = False And Shape1(iaktifsekilkare(2) - 20).Visible = False And iaktifsekilkare(2) > 20 Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) + 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1 - 20
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 4
End If
ElseIf durum = 4 Then
If Shape1(iaktifsekilkare(0) - 10).Visible = False And Shape1(iaktifsekilkare(3) + 1).visible0false And (Not (iaktifsekilkare(3) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 6
If durum = 1 Then
If Shape1(iaktifsekilkare(2) - 1).Visible = False And Shape1(iaktifsekilkare(2) - 11).Visible = False And iaktifsekilkare(2) > 20 Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 11
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 2
End If
ElseIf durum = 2 Then
On Error Resume Next
If Shape1(iaktifsekilkare(3) + 1).Visible = False And (Not (iaktifsekilkare(3) Mod 10 = 0)) And Shape1(iaktifsekilkare(2) + 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(0) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 3
End If
ElseIf durum = 3 Then
On Error Resume Next
If Shape1(iaktifsekilkare(0) - 1).Visible = False And Shape1(iaktifsekilkare(1) + 10).Visible = False And (Not (iaktifsekilkare(0) Mod 10 = 1)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 4
End If
ElseIf durum = 4 Then
If Shape1(iaktifsekilkare(2) + 1).Visible = False And Shape1(iaktifsekilkare(2) - 9).Visible = False And (Not (iaktifsekilkare(1) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(2) = iaktifsekilkare(1) - 9
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 1
End If
End If
End Select
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End Sub
Private Sub form_load()
'şekilleri yerleştirelim
For i = 0 To 20
For k = 1 To 10
Load Shape1(10 * i + k)
If k = 1 Then
Shape1(i * 10 + k).Left = Shape1(0).Left + Shape1(0).Width
Shape1(i * 10 + k).Top = Shape1(0).Top
Else
Shape1(i * 10 + k).Left = Shape1(i * 10 + k - 1).Left + Shape1(i * 10 + k - 1).Width
Shape1(i * 10 + k).Top = Shape1(0).Top
End If
Next
Shape1(0).Top = Shape1(0).Top - Shape1(0).Height
Next
Shape2.Move Shape1(1).Left - 5, Shape1(210).Top - 5, 10 * Shape1(0).Width + 10, Shape1(0).Height * 20 + 10
Call sekilsec
For i = 0 To 10
Shape1(i).Visible = True
Next
level = 0
puan = 0
Label1.Caption = "level" & level
Label2.Caption = "punanınız:" & puan
End Sub
Private Sub sekilsec()
Randomize Timer
k = Int(Rnd * 6) + 1
Select Case k
Case 1: iaktifsekilkare(0) = 204
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 2: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 196
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 3: iaktifsekilkare(0) = 205
iaktifsekilkare(1) = 196
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 197
durum = 1
Case 4: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 196
iaktifsekilkare(3) = 206
durum = 1
Case 5: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 6: iaktifsekilkare(0) = 205
iaktifsekilkare(1) = 206
iaktifsekilkare(2) = 197
iaktifsekilkare(3) = 207
durum = 1
End Select
bidaha:
renk = Int(Rnd * 15) + 1
If renk = 7 Then GoTo bidaha
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End Sub
Private Sub timer1_timer()
devamet = False
For i = 0 To 3
devam(i) = False
Next
If Shape1(iaktifsekilkare(0) - 10).Visible = False Then devam(0) = True
If (iaktifsekilkare(1) - 10 = iaktifsekilkare(0)) Then
devam(1) = True
Else
If Shape1(iaktifsekilkare(1) - 10).Visible = False Then
devam(1) = True
End If
If (iaktifsekilkare(2) - 10 = iaktifsekilkare(1)) Then
devam(2) = True
Else
If Shape1(iaktifsekilkare(2) - 10).Visible = False Then
devam(2) = True
End If
If (iaktifsekilkare(3) - 10 = iaktifsekilkare(2)) Then
devam(3) = True
Else
If Shape1(iaktifsekilkare(3) - 10).Visible = False Then
devam(3) = True
End If
For i = 0 To 3
If devam(i) = True Then
devamet = True
Else
devamet = False
GoTo devamdevam
End If
Next
devamdevam:
If devamet = True Then
For i = 0 To 3
On Error Resume Next
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) - 10
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
Else
Call kontrol
Call sekilsec
End If
End Sub
Private Sub kontrol()
sil(11) = False
basla:
level = Int(puan / 1500)
Select Case level
Case 0: Timer1.Interval = 1000
Case 1: Timer1.Interval = 1000
Case 2: Timer1.Interval = 500
Case 3: Timer1.Interval = 250
Case 4: Timer1.Interval = 125
Case 5: Timer1.Interval = 60
Case 6: Timer1.Interval = 30
Case 7: Timer1.Interval = 15
Case 8: Timer1.Interval = 10
End Select
If level > 8 Then Timer1.Interval = 5
Label1.Caption = "level" & level
For i = 1 To 19
For r = 1 To 10
If Shape1(i * 10 + r).Visible = True Then
sil(r) = True
Else
sil(r) = False
End If
Next
For r = 1 To 10
If sil(r) = True Then
sil(11) = True
Else
sil(11) = False
GoTo silelim
End If
Next
silelim:
If sil(11) = True Then GoTo silbakalim
Next
Exit Sub
silbakalim:
puan = puan + 100
Label2.Caption = "puanınız:" & puan
For s = i To 19
For r = 1 To 10
If Shape1(s * 10 + r + 10).Visible = True Then
Shape1(s * 10 + r).BackColor = Shape1(s * 10 + r + 10).BackColor
Else
Shape1(s * 10 + r).Visible = False
End If
Next
Next
GoTo basla
End Sub
19-04-2006, 17:03
#9 (permalink)
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
Devam
Sayiniz tekmi çiftmi
Kod:
command1_clik
x=val (text1.text)
if x mod 2= 0 then
list2.addlitam x
else
list1.addlitem x
end if
text1.text=""
end sub
command2_cilik
list1.clear
list2.clear
Mouse move ile ilgili bir örnek
Kod:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Select Case Picture1.Align
Case 1
If Y < 50 Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 2
If Y > (Me.Height - 50) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 3
If X < 50 Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 4
If X > (Me.Width - 50) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case Else
If Y > (Picture1.Top) And Y < (Picture1.Top + Picture1.Height) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
End Select
End Sub
Hesap makinesi
Kod:
Dim sonuc, durum, durum2, durum3, islem, adet
Private Sub hafiza(durum)
Static sayi, toplam
Select Case durum
Case 1: toplam = toplam + sayi
Case 2: sayi = Val(Giris)
Case 3: Giris = Str(Giris) + Str(sayi)
Case 4: sayi = 0
End Select
End Sub
Private Sub Btn0_Click()
Giris = Giris + "0"
End Sub
Private Sub Btn1_Click()
If durum = 0 Or durum3 = 0 Then
Giris = "1"
Else
Giris = Giris + "1"
End If
durum = 1
durum3 = 1
adet = 0
End Sub
Private Sub Btn2_Click()
If durum = 0 Or durum
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
Visual Basic içinde Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir) konusu , Evet arkadaşlar hiçbir forum sitesinde bulamazsınız bu kodları bir arada..Sürekli güncellenecektir..***TNSEZER*** Güzel bir ekran koruyucu Kod: Dim a As Long Private Sub Timer1_Timer() Line (800, 800)-(800, 800 + a), Int(Rnd ...
|
|
|
|||||||
| KAYIT OL | Yönetim Takımı | Üye Listesi | Tüm konuları okunmuş kabul et |
|
19-04-2006, 16:37
|
#1 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Visual basic kodları hemde bisürü***tnsezer***(Sürekli güncellenecektir)
Evet arkadaşlar hiçbir forum sitesinde bulamazsınız bu kodları bir arada..Sürekli güncellenecektir..***TNSEZER*** Güzel bir ekran koruyucu Kod:
Dim a As Long Private Sub Timer1_Timer() Line (800, 800)-(800, 800 + a), Int(Rnd * 65000) Line (2000, 800)-(2000, 800 + a), Int(Rnd * 65000) Line (3000, 800)-(3000, 800 + a), Int(Rnd * 65000) Line (4000, 800)-(4000, 800 + a), Int(Rnd * 65000) Line (5000, 800)-(5000, 800 + a), Int(Rnd * 65000) Line (6000, 800)-(6000, 800 + a), Int(Rnd * 65000) Line (7000, 800)-(7000, 800 + a), Int(Rnd * 65000) Line (8000, 800)-(8000, 800 + a), Int(Rnd * 65000) Line (9000, 800)-(9000, 800 + a), Int(Rnd * 65000) Line (10000, 800)-(10000, 800 + a), Int(Rnd * 65000) Line (11000, 800)-(11000, 800 + a), Int(Rnd * 65000) Line (12000, 800)-(12000, 800 + a), Int(Rnd * 65000) Line (13000, 800)-(13000, 800 + a), Int(Rnd * 65000) Line (14000, 800)-(14000, 800 + a), Int(Rnd * 65000) Line (15000, 800)-(15000, 800 + a), Int(Rnd * 65000) Line (800, 800)-(800 + a, 800), Int(Rnd * 65000) Line (800, 2000)-(800 + a, 2000), Int(Rnd * 65000) Line (800, 3000)-(800 + a, 3000), Int(Rnd * 65000) Line (800, 4000)-(800 + a, 4000), Int(Rnd * 65000) Line (800, 5000)-(800 + a, 5000), Int(Rnd * 65000) Line (800, 6000)-(800 + a, 6000), Int(Rnd * 65000) Line (800, 7000)-(800 + a, 7000), Int(Rnd * 65000) Line (800, 8000)-(800 + a, 8000), Int(Rnd * 65000) Line (800, 9000)-(800 + a, 9000), Int(Rnd * 65000) Line (800, 10000)-(800 + a, 10000), Int(Rnd * 65000) Line (800, 11000)-(800 + a, 11000), Int(Rnd * 65000) a = a + 50 End Sub Yazi tipi uygulamasi Kod:
Private Sub Check4_Click() If Check4.Value = 1 Then Check5.Value = 0 Text1.ForeColor = RGB(255, 0, 0) End If End Sub Private Sub Check5_Click() If Check5.Value = 1 Then Check4.Value = 0 Text1.ForeColor = RGB(0, 255, 0) End If End Sub Private Sub Check6_Click() If Check4.Value = 1 Then Check5.Value = 0 Text1.ForeColor = RGB(255, 0, 255) End If End Sub Private Sub Command1_Click() If Check1.Value = 1 Then Text1.FontBold = True Else Text1.FontBold = False End If If Check2.Value = 1 Then Text1.FontItalic = True Else Text1.FontItalic = False End If If Check3.Value = 1 Then Text1.FontUnderline = True Else Text1.FontUnderline = False End If End Sub Private Sub Command2_Click() End End Sub Private Sub Command3_Click() Text1.FontSize = Text1.FontSize - 5 End Sub Private Sub Command4_Click() Text1.FontSize = Text1.FontSize + 5 End Sub Vscrollbar ile fomda arka plan rengi ayarlama Kod:
Private Sub VScroll1_Change() Form1.BackColor = _ RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value) End Sub Private Sub VScroll2_Change() Form1.BackColor = _ RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value) End Sub Private Sub VScroll3_Change() Form1.BackColor = _ RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value) End Sub |
|
|
|
|
19-04-2006, 16:40
|
#2 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Sayi bulma oyunu Alt Alta 5 Tane Text Box Açyn ve 2 Tane de Command Buton Ekleyin... Kod:
dim tes as integer dim st as integer dim sakla as integer dim uyary as string dim i as integer ________________________________ Private Sub Form_Load() End Sub ________________________________ Private Sub Command1_Click() tes = Text1.text sakla = tes Text4.text =sakla Text1.text="" End Sub ________________________________ Private Sub Command2_Click() tes =Text1.text st =Text2.text If st = sakla Then i = i + 1 uyary="Tebrikler i denemede bildiniz!" Text5.text = i End If If st < sakla Then i = i + 1 Text2.text = "" uyary="Tahmininiz Küçük!" Text5.text = i End If If st > sakla Then i = i + 1 Text2.text = "" uyary="Tahmininiz Büyük!" Text5.text = i End If Text3.text = uyary End Sub Hesap makinasi Kod:
Dim a As Double Dim b As Double Private Sub Command1_Click() Label1.Caption = a & "1" a = Label1.Caption If a = 1 Then Label1.Caption = "1" End If End Sub Private Sub Command2_Click() Label1.Caption = a & "2" a = Label1.Caption If a = 2 Then Label1.Caption = "2" End If End Sub Private Sub Command3_Click() Label1.Caption = a & "3" a = Label1.Caption If a = 3 Then Label1.Caption = "3" End If End Sub Private Sub Command4_Click() Label3.Caption = Val(a) + Val(b) End Sub Private Sub Command5_Click() Label3.Caption = Val(a) * Val(b) End Sub Private Sub Command6_Click() Label2.Caption = b & "1" b = Label2.Caption If b = 1 Then Label2.Caption = "1" End If End Sub Private Sub Command7_Click() Label2.Caption = b & "2" b = Label2.Caption If b = 2 Then Label2.Caption = "2" End If End Sub Private Sub Command8_Click() Label2.Caption = b & "3" b = Label2.Caption If b = 3 Then Label2.Caption = "3" End If End Sub List kutusunu access veritabanina baglamak forma bi tane data nesnesi bi tane de list kutusu ekleyin. Kod:
Private Sub Form_Activate() Data1.Recordset.MoveFirst Do Until Data1.Recordset.EOF List1.AddItem (Data1.Recordset![mallar]) Data1.Recordset.MoveNext Loop End Sub Private Sub Form_Load() Data1.DatabaseName = App.Path & "\sabit.mdb" Data1.RecordSource = "tbl_stok" End Sub |
|
|
|
|
19-04-2006, 16:44
|
#3 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Bilgisayarin sesini açip kisabilirsiniz 1- Forma 1 tane modül, 6 tane label, 2 tane timer, 1 tane check kutusu, 2 tane slider kontrolü(MSCOMCTL.OCX) ekleyin. ''''''''''''''''''''''''''''Modüle eklenecek kisim'''''''''''''''''''''''''''' Kod:
Public Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long Public Declare Function waveOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long Public Const MAXPNAMELEN = 32 ' max product name length (including NULL) Public Type WAVEOUTCAPS wMid As Integer wPid As Integer vDriverVersion As Long szPname As String * MAXPNAMELEN dwFormats As Long wChannels As Integer dwSupport As Long End Type Public Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long Public Declare Function waveOutGetDevCaps Lib "winmm.dll" Alias "waveOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As WAVEOUTCAPS, ByVal uSize As Long) As Long Kod:
Private Sub Check1_Click()
Timer1.Interval = 0
Timer2.Interval = 0
End Sub
Private Sub Form_Load()
label1.caption="sag"
label2.caption="sol"
label3.caption="alçak"
label4.caption="yüksek"
label5.caption="alçak"
label6.caption="yüksek"
check1.caption="Kaydirma Göstergeleri Ayni Anda Hareket Etsin"
Dim lpc As WAVEOUTCAPS
If waveOutGetNumDevs() = 0 Then
MsgBox ("Ses çalacak donanmim yok")
End If
Call waveOutGetDevCaps(0, lpc, Len(lpc))
If lpc.wChannels = 0 Then
Slider2.Visible = False [m]'mono ise birini gizle[/m]
End If
If (lpc.dwSupport And 4) = 0 Then [m]'ses ayarini desteklemiyorsa ikisinide gizle[/m]
Slider1.Visible = False
Slider2.Visible = False
End If
If (lpc.dwSupport And 8) = 0 Then [m]'sol sag ses ayarini desteklemiyorsa birini gizle[/m]
Slider2.Visible = False
End If
Slider1.Min = 0
Slider1.Max = &HFFFF&
Slider1.TickFrequency = &HFFFF& / 10
Slider2.Min = 0
Slider2.Max = &HFFFF&
Slider2.TickFrequency = &HFFFF& / 10
Dim x, sol, sag, st [m]'su anki seviyeyi göster[/m]
Call waveOutGetVolume(0, x)
sol = x And &HFFFF& [m]'düsük seviyeli 2byte[/m]
st = Hex(x And &HFFFF0000)
If Len(st) > 4 Then
st = Mid(st, 1, Len(st) - 4) [m]'yüksek seviyeli 2 bayti al[/m]
Else
st = 0
End If
sag = CDbl("&h" & st)
Slider1.Value = sol
Slider2.Value = sag
End Sub
Sub sesayar()
Dim x, sol, sag, s
sol = Slider1.Value
sag = Slider2.Value
s = Val("&h" & Hex(sag) & String(4 - Len(Hex(sol)), "0") & Hex(sol) & "&")
Call waveOutSetVolume(0, s)
End Sub
Private Sub Slider1_Click()
sesayar
End Sub
Private Sub Slider1_Scroll()
If Check1.Value = 0 Then
Else
Timer1.Interval = 0
Timer2.Interval = 1
End If
sesayar
End Sub
Private Sub Slider2_Click()
sesayar
End Sub
Private Sub Slider2_Scroll()
If Check1.Value = 0 Then
Else
Timer2.Interval = 0
Timer1.Interval = 1
End If
sesayar
End Sub
Private Sub Timer1_Timer()
Slider1 = Slider2
End Sub
Private Sub Timer2_Timer()
Slider2 = Slider1
End Sub
Ek kontrollerin bulunduklari .ocx dosyalari PictureBox, Label, TextBox, Image, ListBox, Combobox, OptionButton, CheckBox, ScrollBar, Frame, Timer, DriveListbox, DirectoryListBox, FileListBox, Shape, Line, Data Kontrolleri herhangi bir dosyaya ihtiyaç duymaksizin araççubugundaki (toolbox) yerini alir. Ancak diger kontrolleri kullanabilmek için o kontrollerin bulundugu OCX dosyasini Vb'ye eklemek gerekir. Asagidaki tabloda Hangi OCX dosyasinda hangi kontrollerin bulundugu gösteriliyor. Bu Controllerden birini kullanabilmek için "Project" / "Components" menülerini takip edip Listeden seçebilirsiniz, Eger listede yoksa "Browse" dügmesine basin ve dosyayi bulup seçin. Component Adi Dosya Adi Kontroller Kod:
Microsoft(MS) ADO Data Cont. 6.0 MSADODC.OCX ADO Data Control MS Chart Control 5.5 MSCHART.OCX Microsoft Chart MS Comm Control 6.0 MSCOMM32.OCX MSComm MS Common Dialog Control 6.0 COMDLG32:OCX Common Dialog MS Data Bound Grid Control 5.0 DBGRID32.OCX DBGrid MS Data Bound List Controls 6.0 DBLIST32.OCX DBList, DBCombo MS Data Repeater Control 6.0 MSDATREP.OCX DataRepeater MS Data Grid Control 6.0 MSDATGRD.OCX DataGrid MS Data List Controls 6.0 MSDATLST.OCX DataList, DataCombo MS FlexGrid Control 6.0 MSFLXGRD.OCX MsFlexGrid MS Grid Control GRID32.OCX Grid MS Hierarchical Flex Grid Control 6.0 MSHFLXGD.OCX MSHFlexGrid MS Internet Transfer Control 6.0 MSINET.OCX Inet MS MAPI Controls 6.0 MSMAPI32.OCX MapiMessages, MAPISession MS MaskedEdit Control 6.0 MSMASKE32.OCX MaskedEdit MS Multimedia Control 6.0 MCI32.OCX Multimedia MCI MS PictureClip Control 6.0 PICCLP32.OCX PictureClip MS RemoteData Control 6.0 MSRDC20.OCX RemoteData MS RichTextBox Control 6.0 RICHTX.OCX RichTextBox MS SysInfo Conterol 6.0 SYSINFO.OCX SysInfo MS TabbedDialog Control 6.0 TABCTL32.OCX Ms Tab Control MS Windows Common Controls 6.0 MSCOMCTL.OCX TabStrip, Toolbar, StatusBar, ProgressBar, TreeView, ListView, ImageList, Slider, ImageCombo MS WIndows Common Controls-2 6.0 MSCOMCTL2.OCX Animation, UpDown, MonthView, DTPicker, FlatScrollbar MS Windows Common Controls-3 6.0 MSCOMCTL3.OCX CoolBar MS Winsock Control 6.0 MSWINSOCK.OCX Winsock |
|
|
|
|
19-04-2006, 16:47
|
#4 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Program yaziyosaniz lazimdir 1_ Visual Basic Service Pack 6.0 (vb'nin sp 6 güncellestirmesidir.) http://www.microsoft.com/downloads/i...82/Vs6sp6B.exe 2_ Visual Basic Runtime 6.0 (vb'nin çalisma dosyalaridir) http://download.microsoft.com/downlo...vbrun60sp3.EXE 3_ Microsoft Data Access Component (MDAC) 2.5 (veritabani uygulamasi olan programlar için access yamasidir) http://www.microsoft.com/downloads/i...S/MDAC_TYP.EXE 4_ Visual Basic Kod Bankasi 1.7 (Tam 2081 adet vb kodu içerir) http://www.sezginweb.com/programlar/vbkodbank17.exe 5_ Setup Pro (Türkçe bir setup hazrlama programidir) http://www.sezginweb.com/programlar/setuppro.rar 6_ Cyrstal Reports 10 (vb üzerinde raporlama yapmak isteyenler için) http://ftp.crystaldecisions.com/outg.../CR10DevEn.exe 7_ 1000 adet hazir icon (programinizda kullanabileceginiz 100 adet hazir icon bu dosyanin içinde) http://www.vbasicmaster.com/zips/icons.zip 8_ Help Creator (vb'de yardim(help) dosyalari hazirlayabilirsiniz.) http://www.breittechnologies.com/pro...torInstall.exe 9_ API-Guide V 3.7.854 (Apilerle ilgili birçok bilgi içeriyor) http://www.student.kuleuven.ac.be/~m....7/agsetup.exe Forma media playeri çagirma Kod:
Private Sub Command11_Click()
Call Shell("C:\Program Files\Windows Media Player\wmplayer.exe /prefetch:1.exe", 1)
End Sub
Dosyanin tam yolunu yazmak zorunda degilsiniz Kod:
Private Sub Form_Load() Dim Path As String Path = "c:\windows\media\tada.wav" MsgBox Path Path = StrReverse(Split(StrReverse(Path), "\")(0)) MsgBox Path End Sub |
|
|
|
|
19-04-2006, 16:51
|
#5 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Internetteki access veritabanindaki kayit sayisi Project/Components'ten Microsoft Internet Transfer Control Microsoft Ado Data Control Microsoft Datagrid Control projenize eklyin 1 adet label ve 1 adet command ekleyin kodlari oldugu gibi forma yapistirin Kod:
Private Sub Command1_Click() Label1.Caption = "Veritabaninda toplam " & Adodc1.Recordset.RecordCount & " kayit var" End Sub Private Sub Form_Load() Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=\\www.sezginweb.com\deneme\kayit.mdb" Adodc1.RecordSource = "tblogrenciler" Set DataGrid1.DataSource = Adodc1 End Sub Her türlü müzik dosyasini çalma project componentten microsoft common dialog control ü ekleyin 4 command 1 tanede text kutusu ekleyin olduğu gibi forma yapıştırn Kod:
Private 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
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Sub Command1_Click()
Dim Hata As Long
Dim HataMesaji As String * 128
'Mesajı gönderiyoruz
Hata = mciSendString("open " & Chr$(34) & Text1.Text & Chr$(34) & " alias YeniSes", 0, 0, 0)
'Hata Mesajını Alıyoruz
mciGetErrorString Hata, HataMesaji, 128
MsgBox HataMesaji
End Sub
Private Sub Command2_Click()
mciSendString "play YeniSes", 0, 0, 0
End Sub
Private Sub Command3_Click()
mciSendString "close Yenises", 0, 0, 0
End Sub
Private Sub Command4_Click()
On Error GoTo error
With CommonDialog1
.CancelError = True
.DialogTitle = "Ses Dosyası aç_-_-_-_-Sunasoft Yazılım Bilgisayar-_-_-_-_"
.Filter = "Şarkı Dosyaları (*.mp3) |*.mp3; |Ses Dosyaları (*.wav) |*.wav; |Midi Dosyaları (*.mid) |*.mid"
.InitDir = "c:\"
.ShowOpen
If Len(.FileName) = 0 Then Exit Sub
Text1.Text = .FileName
cmdPlay.SetFocus
End With
error:
End Sub
Private Sub Form_Load()
'''Buraları bilmesenizde olur ben sadece nasıl çalıştığını görün diya yaptım
Left = (Screen.Width - Width) \ 2
Top = (Screen.Height - Height) \ 2
Command1.Caption = "Yükle"
Command2.Caption = "Çal"
Command3.Caption = "Dur"
Command4.Caption = "Gözat"
Form1.Height = 4920
Form1.Width = 8820
Command1.Top = 720
Command1.Left = 480
Command2.Top = 1320
Command2.Left = 480
Command3.Top = 1920
Command3.Left = 480
Command4.Top = 2400
Command4.Left = 6600
Text1.Top = 2520
Text1.Left = 480
Text1.Height = 285
Text1.Width = 6015
End Sub
Vb üzerinden excelde arama yapmak Project/References menülerinden "Microsoft Excel 10.0 Object Library" ekleyin, Formunuza 9 adet text kutusu, 9 adet label ve bir adet command butonu ekleyin, ve aşağıdaki kodları olduğu gibi forma yapıştırın ve çalıştırın. Kod:
Dim c As Excel.Range
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Sub ExcelAra()
On Error GoTo hata
Set xlApp = New Excel.Application
Text2.Text = ""
Set xlBook = Workbooks.Open(App.Path & "\devlet_kurumlari.xls", , True)
Set xlSheet = xlBook.Worksheets("sheet 1")
With xlSheet.Range("a1:c65536")
Set c = .Find(Trim(Text1.Text), lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Text2.Text = c.Address
Range(Text2.Text).Select
Text3.Text = Excel.ActiveCell.Row
'??????_______Kurum Adı
Range("$d$" & Text3.Text).Select
Text4.Text = Excel.ActiveCell
'??????_______Kurum İli
Range("$a$" & Text3.Text).Select
Text5.Text = Excel.ActiveCell
'??????_______Kurum İlçesi
Range("$b$" & Text3.Text).Select
Text6.Text = Excel.ActiveCell
'??????_______Kurum Telefonu
Range("$e$" & Text3.Text).Select
Text7.Text = Excel.ActiveCell
MaskEdBox1.Text = Excel.ActiveCell
'??????_______Kurum Fax
Range("$f$" & Text3.Text).Select
Text8.Text = Excel.ActiveCell
'??????_______Kurum Adres
Range("$g$" & Text3.Text).Select
Text9.Text = Excel.ActiveCell
Do
c.Interior.Pattern = xlPatternGray50
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
If Text2.Text = "" Then Text2.Text = "Bulunamadı..."
xlBook.Close False
xlApp.Quit
Exit Sub
hata:
MsgBox Err.Description
End Sub
Private Sub Command1_Click()
ExcelAra
End Sub
|
|
|
|
|
19-04-2006, 16:55
|
#6 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Bilgisayar her açildiginda program çalissin mi çalismasin mi? Forma bi tane checkbox, bi tane label, bitane textbox, bitane de data nesnesi koyun. bi tane veritabanı oluşturun(access) adınıda sabit.mdb yapın.bu veritabanında bi tane tablo oluşturun adını tbl_kontrol yapın.Bu tabloda bi tane alan oluşturun adını da windows_acilis yapın. text1 nesnesi data1'e bağlayın. label'in captionuna "Bilgisayar her açıldığında program çalışsın" yazın. Bu veritabanı programınızla aynı klasörde olsun. '''''''''''''''''''''''''''''BİTTİ'''''''''''''''' '''''''''''''''''''''''''''''' Kod:
Private Sub Check1_Click()
If Check1.Value = 0 Then
Text1.Text = "1"
End If
If Check1.Value = 1 Then
Text1.Text = "2"
End If
Dim KayitDefteri As Object
Set KayitDefteri = CreateObject("wscript.shell")
If Text1.Text = "1" Then
KayitDefteri.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN\" & App.EXEName, "" & "" & "" & ""
End If
If Text1.Text = "2" Then
KayitDefteri.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
End If
End Sub
Private Sub Form_Activate()
If Text1.Text = "1" Then
Check1.Value = 0
End If
If Text1.Text = "2" Then
Check1.Value = 1
End If
End Sub
Private Sub Form_Load()
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_kontrol"
Text1.DataField = "windows_acilis"
End Sub
Winampa benziyor İlk Yapılacaklar : 1- Bi tane veritabanı oluşturun, adı sabit.mdb olsun. 2- Bu veritabanında bi tane tablo oluşturun adı tbl_muzikyayini olsun. 3- Bu tabloyada iki tane alan yerleştirin, biri zil_müzikler_toplanmis diğeri zil_müzikler_acilmis olsun. 4- Sonra forma; 2 list kutusu, 4 text kutusu, 1 comman button, 1 data nesnesi, 2 timer, 1 tanede commondialog control ekleyin. 5- Commanbuttonun captionuna ekle yazın. 6- Timerlerin interval özelliğini 1 yapın. Açıklama : 1- Commandbutonun captionuna ekle yazın, bununla belirttiğimiz bir klasörden müzik dosyasını list2'ye akatarıcaz.list2'de dosyanın tam yolu yazacağı için, ordan list1'e sadece müzik dosyasının adı gelecek. 2- Text4 ile müziğin şu an çalıp çalmadığını kontrol edicez, çalıyosa playing yazacak, çalmıyorsa stoping yazacak. 3- Timer2 ile durumu kontrol edicez müzik dosyası çalıyomu çalmıyomu, buna göre bir sonraki müzik dosyasını çaldırtıcaz. 4- Timer1 ile de duruma göre bir sonraki müzik dosyasını çaldırıcaz. 5- Text3 ile çalınan müzik dosyasının uzunluğunu dakika cinsinden göstericez. VEEEE AŞAĞIDAKİ KODLARI OLDUĞU GİBİ FORMA YAPIŞTIRICAZ Kod:
Private 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
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Function StripPath(T$) As String '''''''Dosyanın kısa adını gösteren kod
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
ct% = x%
x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
Private Sub Command1_Click() '''''Projemize müzik dosyası buradan ekleniyor
On Error Resume Next
Data1.Recordset.AddNew
Data2.Recordset.AddNew
With CommonDialog1
'On Cancel do nothing
.CancelError = True
.DialogTitle = "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\Sunasoft Yazılım///////////////////////////////////"
.Filter = "Hepsi ( *.mp3 *.wav *.mid ) |*.mp3;*.wav;*.mid|Şarkı Dosyaları (*.mp3) |*.mp3; |Ses Dosyaları (*.wav) |*.wav; |Midi Dosyaları (*.mid) |*.mid"
.InitDir = App.Path & "\müzikler\"
.ShowOpen
'Handle no filename
If Len(.FileName) = 0 Then Exit Sub
Text1.Text = .FileName
List1.AddItem Text1.Text
file = StripPath(Text1.Text)
Text2.Text = file
List2.AddItem file
List1.Clear
List2.Clear
Form_Activate
End With
error: 'Do nothing
End Sub
Private Sub Form_Activate() '''Burada list kutusunu veritabanına bağlıyoruz
On Error Resume Next
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List1.AddItem (Data1.Recordset![zil_müzikler_acilmis])
Data1.Recordset.MoveNext
Loop
Data1.Recordset.MoveFirst
Do Until Data1.Recordset.EOF
List2.AddItem (Data1.Recordset![zil_müzikler_toplanmis])
Data1.Recordset.MoveNext
Loop
End Sub
Private Sub Form_Load() ''''Data nesenesine bağlantı ayarları buradan yapılıyor
mciSendString "close Yenises", 0, 0, 0 'Müzik dosyasını kapat
Data1.DatabaseName = App.Path & "\sabit.mdb"
Data1.RecordSource = "tbl_muzikyayini"
End Sub
Private Sub Form_Unload(Cancel As Integer) '''Çıkarken çalan müziği kapatıyoruz
mciSendString "close Yenises", 0, 0, 0
End Sub
Private Sub List2_Click() ''''List2'de tıklanan müziği çaldırtıyoruz
On Error Resume Next
Dim i
For i = 0 To List2.ListCount - 1
If List2.Selected(i) Then
mciSendString "close Yenises", 0, 0, 0
Hata = mciSendString("open " & Chr$(34) & List2.List(i) & Chr$(34) & " alias YeniSes", 0, 0, 0)
mciSendString "play YeniSes", 0, 0, 0 'Müziği oynatma kısmı
Dim Dondur As String * 128 '''Burada adı geçen dondur=çalmasüresidir
mciSendString "status YeniSes length", Dondur, 128, 0
Text3.Text = ((Dondur / 60000))
End If
Next
End Sub
Private Sub Timer1_Timer()
If Text4.Text = "stopped" Then 'Eğer müzik dosyası çalmıyorsa demek oluyo.
If List2.ListIndex = List2.ListCount - 1 Then '''Eğer listenin sonuna gelinmişşe
List2.Selected(0) = True '''Listenin en başındakini seç
Else 'Gelmemişse daha o zaman alttaki koddan devam et
List2.Selected(List2.ListIndex + 1) = True ''Bir önceki dosyadan sonrakini çalmaya devam et
End If
For i = 0 To List2.ListCount - 1
If List2.Selected(i) Then
mciSendString "close Yenises", 0, 0, 0
Hata = mciSendString("open " & Chr$(34) & List2.List(i) & Chr$(34) & " alias YeniSes", 0, 0, 0)
mciSendString "play YeniSes", 0, 0, 0
Dim Dondur As String * 128
mciSendString "status YeniSes length", Dondur, 128, 0
Text3.Text = ((Dondur / 60000))
End If
Next
End If
End Sub
Private Sub Timer2_Timer() '''Durumu sürekli olarak kontrol et
Dim Durum As String * 128
mciSendString "status YeniSes mode", Durum, 128, 0
Text4.Text = Durum
End Sub
Araba yarisi Evet Arkadaşlar merhaba şimdi sizinle araba yarışı yapacagız Araçlar : 1) iki tane Shape ekliyoruz bunlar araba olucak bu Shape adını Shape1 ve Shape2 yapıyoruz. 2) Timer ekliyoruz Left 5280 Top 3120 olarak değiştiriyoruz. 3) Command buton ekliyoruz Aşağıda vermiş olduğum kodu ekliyoruz bu kadar. Kod:
Private Sub Command1_Click()
Timer1.Interval = 10
Timer2.Interval = 10
End Sub
Private Sub Form_Load()
End Sub
Private Sub Timer1_Timer()
Randomize
g = Rnd(100) * 100
Shape1.Move Shape1.Left + g
If Shape1.Left >= 8000 Then
MsgBox ("kazanan pembe araba")
End
End If
End Sub
Private Sub Timer2_Timer()
Randomize
f = Rnd(100) * 100
Shape2.Move Shape2.Left + f
If Shape2.Left >= 8000 Then
MsgBox ("kazanan beyaz araba")
End
End If
End Sub
|
|
|
|
|
19-04-2006, 16:57
|
#7 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Oyun yasin ' 2 adet timer 1 label 1 pictrue box ve bir tane command tuşu form da bulunması gerekenlerdendir Dim satirsayisi, sutunsayisi, kutusayisi, puan Kod:
Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.Left = Command1.Left + 100
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyLeft: Command1.Left = Command1.Left - 15
Case vbKeyRight: Command1.Left = Command1.Left + 15
If Command1.Left >= Form1.ScaleWidth - Command1.Width Then
Command1.Left = Form1.ScaleWidth - Command1.Width
End If
End Select
End Sub
Private Sub Form_Load()
Caption = "yasin çakmak"
Dim i, j, k
Show
ScaleMode = 3 'pixel
KeyPreview = True
satirsayisi = 5
sutunsayisi = 10
kutusayisi = satirsayi * sutunsayisi
Timer1.Interval = 10
Timer2.Interval = 10
Command1.Top = ScaleHeight - Label1.Height
Label1 = "0 "
Shape1.Shape = 3
Shape1.FillStyle = 7
Shape1.Width = 18
Shape1.Height = 18
Picture1(0).Width = 60
Picture1(0).Height = 20
widh = Picture1(0).Width * sutunsayisi * Screen.TwipsPerPixelX + 30
Picture1(0).Move 0, 0
Picture1(0).BackColor = QBColor(1)
For i = 1 To satirsayisi
For j = 1 To sutunsayisi
k = k + 1
Load Picture1(k)
Picture1(k).Left = Picture1(k - 1).Left + Picture1(k).Width
Picture1(k).Top = (i - 1) * Picture1(k).Height
Picture1(k).Visible = True
Picture1(k).BackColor = QBColor(i)
Next
Picture1(k).Left = 0
Next
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command1.Left = X
End Sub
Private Sub Timer1_Timer()
Static xa, ya
If IsEmpty(xa) Then xa = 10: ya = 10
If Shape1.Left <= 0 Then xa = -xa
If Shape1.Left >= ScaleWidth Then xa = -xa
If Shape1.Top < 0 Then ya = -ya
If (Shape1.Top >= Command1.Top) And (Shape1.Top < (Command1.Top + Command1.Height)) And Shape1.Left > Command1.Left And Shape1.Left < (Command1.Left + Command1.Width) Then ya = -ya
If Shape1.Top >= ScaleHeight Then
MsgBox "oyun bitti"
Timer1.Interval = False
End
End If
Dim i, j, k
k = -1
For i = 1 To sutunsayisi
For j = 1 To satirsayisi
k = k + 1
If Picture1(k).Visible = True And Shape1.Left >= Picture1(k).Left And Shape1.Left < (Picture1(k).Left + Picture1(k).Width) And Shape1.Top <= (Picture1(k).Top + Picture1(k).Height) Then
Picture1(k).Visible = False
kutusayisi = kutusayisi - 1
ya = -ya
puan = puan + 100
Label1 = puan
End If
Next
Next
Shape1.Left = Shape1.Left + xa
Shape1.Top = Shape1.Top + ya
If kutusayisi = 1 Then
MsgBox ("tebrikler")
End If
End Sub
Private Sub Timer2_Timer()
Picture1(Rnd * (satirsayisi * sutunsayisi - 1)).BackColor = QBColor(Rnd * 15)
End Sub
Yanip sönen buton Kod:
Private Sub Timer1_timer command1.backgroundcolor = ffff00 Command1.backgroundcolor=0f0f end sub Basit bir kronometre Kod:
Private Sub basla_Click() Timer1.Enabled = True Timer1.Interval = 1000 End Sub Private Sub durudur_Click() Timer1.Enabled = False Label8.Caption = saat Label9.Caption = dakika Label10.Caption = saniye End Sub Private Sub Timer1_Timer() Label3.Caption = Now saniye = saniye + 1 If saniye = 59 Then dakika = dakika + 1 saniye = 0 End If If dakika = 59 Then saat = saat + 1 dakika = 0 End If Label4.Caption = saat Label5.Caption = dakika Label6.Caption = saniye End Sub |
|
|
|
|
19-04-2006, 17:00
|
#8 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Ethernet kartinin mac adresini alma Kod:
Private Const NCBASTAT As Long = &H33
Private Const NCBNAMSZ As Long = 16
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private Const HEAP_GENERATE_EXCEPTIONS As Long = &H4
Private Const NCBRESET As Long = &H32
Private Type NET_CONTROL_BLOCK
ncb_command As Byte
ncb_retcode As Byte
ncb_lsn As Byte
ncb_num As Byte
ncb_buffer As Long
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte
ncb_sto As Byte
ncb_post As Long
ncb_lana_num As Byte
ncb_cmd_cplt As Byte
ncb_reserve(9) As Byte
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(5) As Byte
rev_major As Byte
reserved0 As Byte
adapter_type As Byte
rev_minor As Byte
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NET_CONTROL_BLOCK) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Function GetMACAddress() As String
Dim tmp As String
Dim pASTAT As Long
Dim NCB As NET_CONTROL_BLOCK
Dim AST As ASTAT
NCB.ncb_command = NCBRESET
Call Netbios(NCB)
NCB.ncb_callname = "* "
NCB.ncb_command = NCBASTAT
NCB.ncb_lana_num = 0
NCB.ncb_length = Len(AST)
pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, NCB.ncb_length)
If pASTAT = 0 Then
Debug.Print "memory allocation failed!"
Exit Function
End If
NCB.ncb_buffer = pASTAT
Call Netbios(NCB)
CopyMemory AST, NCB.ncb_buffer, Len(AST)
tmp = Format$(Hex(AST.adapt.adapter_address(0)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(1)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(2)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(3)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(4)), "00") & " " & Format$(Hex(AST.adapt.adapter_address(5)), "00")
HeapFree GetProcessHeap(), 0, pASTAT
GetMACAddress = tmp
End Function
Private Sub Form_Load()
MsgBox "Ethernet kartının MAC adresi: " + GetMACAddress()
End Sub
Basit bir screen saver Kod:
Declare Function ShowCursor Lib "user32" (ByVal fShow As Integer) As Integer
Global maxLines As Integer
Sub endScrnSave()
showmouse
End
End Sub
Sub HideMouse()
While ShowCursor(False) >= 0
Wend
End Sub
Sub main()
BlankForm.Show
End Sub
Sub showmouse()
While ShowCursor(True) < 0
Wend
End Sub
'Formuna bir tane timer ekle interval=100 yap
'Formun özelliklerini border style=none yap
'Formun backcolor'unu siyah yap ve aşağıdaki kodu pastele.
'exe file yaparkende exe yi scr olarak değiştir windows\ system yapıştır.
'hadi kolay gelsin. Batuge'den :)
Dim lastX, lastY
Dim numlines
Sub form_Keydown(Keycode As Integer, Shift As Integer)
endScrnSave
End Sub
Private Sub Form_Load()
Move 0, 0, Screen.Width, Screen.Height
HideMouse
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If IsEmpty(lastX) Or IsEmpty(lastY) Then
lastX = X
lastY = Y
End If
If Abs(lastX - X) > 2 Or Abs(lastY - Y) > 2 Then
endScrnSave
End If
lastX = X
lastY = Y
End Sub
Private Sub Timer1_Timer()
Dim CX, CY, Radius, Limit
ScaleMode = 3
CX = ScaleWidth / 2
CY = ScaleHeight / 2
If CX > CY Then Limit = CY Else Limit = CX
For Radius = 0 To Limit
Circle (CX, CY), Radius, RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Next Radius
End Sub
Basit tetris Kod:
Option Explicit
Private i, k, durum, renk, r, s, level, puan
Private iaktifsekilkare(3) As Integer
Private devam(3) As Boolean
Private devamet As Boolean
Private sola(3) As Boolean
Private solagit As Boolean
Private saga(3) As Boolean
Private sagagit As Boolean
Private sil(11) As Boolean
Private Sub form_keydown(keycode As Integer, shift As Integer)
On Error Resume Next
If keycode = vbKeyLeft Then
If Not (iaktifsekilkare(0) Mod 10 = 1) Then
If Shape1(iaktifsekilkare(0) - 1).Visible = False Then
sola(0) = True
Else
sola(0) = False
End If
If (iaktifsekilkare(1) - 1 = iaktifsekilkare(0)) Then
sola(1) = True
Else
sola(1) = False
End If
End If
If ((iaktifsekilkare(2) - 1 = iaktifsekilkare(0)) Or (iaktifsekilkare(2) - 1 = iaktifsekilkare(1))) Then
sola(2) = True
Else
If Shape1(iaktifsekilkare(2) - 1).Visible = False Then
sola(2) = True
Else
sola(2) = False
End If
End If
If ((iaktifsekilkare(3) - 1 = iaktifsekilkare(0)) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(1)) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(1) Or (iaktifsekilkare(3) - 1 = iaktifsekilkare(2)))) Then
sola(3) = True
Else
If Shape1(iaktifsekilkare(3) - 1).Visible = False Then
sola(3) = True
Else
sola(3) = False
End If
End If
For i = 0 To 3
If sola(i) = True Then
solagit = True
Else
solagit = False
GoTo soladevam
End If
Next
soladevam:
If solagit = True Then
If solagit = True Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) - 1
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End If
End If
End If
If keycode = vbKeyRight Then
If Not (iaktifsekilkare(3) Mod 10 = 0) Then
If Shape1(iaktifsekilkare(3) + 1).Visible = False Then
saga(3) = True
Else
saga(3) = False
End If
If (iaktifsekilkare(2) + 1 = iaktifsekilkare(3)) Then
saga(2) = True
Else
If Shape1(iaktifsekilkare(2) + 1).Visible = False Then
saga(2) = True
Else
saga(2) = False
End If
End If
If ((iaktifsekilkare(1) + 1 = iaktifsekilkare(3)) Or (iaktifsekilkare(1) + 1 = iaktifsekilkare(2))) Then
saga(1) = True
Else
If Shape1(iaktifsekilkare(1) + 1).Visible = False Then
saga(1) = True
Else
saga(1) = False
End If
End If
If ((iaktifsekilkare(0) + 1 = iaktifsekilkare(3)) Or (iaktifsekilkare(0) + 1 = iaktifsekilkare(2)) Or (iaktifsekilkare(0) + 1 = iaktifsekilkare(1))) Then
saga(0) = True
Else
If Shape1(iaktifsekilkare(0) + 1).Visible = False Then
saga(0) = True
Else
saga(0) = False
End If
End If
For i = 0 To 3
If saga(i) = True Then
sagagit = True
Else
sagagit = False
GoTo sagadevam
End If
Next
sagadevam:
If sagagit = True Then
For i = 3 To 0 Step -1
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) + 1
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End If
End If
If keycode = vbKeyDown Then
Timer1.Enabled = False
Timer1.Interval = 10
Timer1.Enabled = True
End If
If keycode = vbKeySpace Then
Select Case k
Case 1
If durum = 1 Then
On Error Resume Next
If Shape1(iaktifsekilkare(1) - 20).Visible = False And Shape1(iaktifsekilkare(1) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1) - 20
iaktifsekilkare(1) = iaktifsekilkare(1) - 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(1) + 20
durum = 2
End If
ElseIf durum = 2 Then
On Error Resume Next
If Shape1(iaktifsekilkare(2) - 1).Visible = False And Shape1(iaktifsekilkare(2) + 1).Visible = False And Shape1(iaktifsekilkare(2) + 2).Visible = False And (Not iaktifsekilkare(2) Mod 10 = 1) And (iaktifsekilkare(2) Mod 10 < 9) And (Not (iaktifsekilkare(2) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 1
iaktifsekilkare(1) = iaktifsekilkare(2)
iaktifsekilkare(2) = iaktifsekilkare(2) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 2
If durum = 1 Then
If iaktifsekilkare(2) < 200 Then
If Shape1(iaktifsekilkare(2) + 10).Visible = False And Shape1(iaktifsekilkare(3) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(3) - 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(0) - 11).Visible = False And Shape1(iaktifsekilkare(0) - 10).Visible = False And Not (iaktifsekilkare(0) Mod 10 = 1) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 11
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 3
If durum = 1 Then
If iaktifsekilkare(2) < 200 Then
If Shape1(iaktifsekilkare(2) + 10).Visible = False And Shape1(iaktifsekilkare(0) - 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 10
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(2)
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(2) - 9).Visible = False And Shape1(iaktifsekilkare(2) - 10).Visible = False And Not (iaktifsekilkare(2) Mod 10 = 0) And Not (iaktifsekilkare(0) Mod 10 = 1) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1)
iaktifsekilkare(1) = iaktifsekilkare(0) - 9
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(1) + 1
durum = 1
End If
End If
Case 4
Case 5
If durum = 1 Then
If iaktifsekilkare(1) < 190 Then
If Shape1(iaktifsekilkare(1) + 10).Visible = False And Shape1(iaktifsekilkare(1) + 20).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(1)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(0) + 1
durum = 2
End If
End If
ElseIf durum = 2 Then
If Shape1(iaktifsekilkare(3) + 10).Visible = False And Shape1(iaktifsekilkare(0) - 1).Visible = False And (Not (iaktifsekilkare(0) Mod 10 < 2)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 3
End If
ElseIf durum = 3 Then
If Shape1(iaktifsekilkare(2) - 10).Visible = False And Shape1(iaktifsekilkare(2) - 20).Visible = False And iaktifsekilkare(2) > 20 Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) + 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1 - 20
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 4
End If
ElseIf durum = 4 Then
If Shape1(iaktifsekilkare(0) - 10).Visible = False And Shape1(iaktifsekilkare(3) + 1).visible0false And (Not (iaktifsekilkare(3) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 1
End If
End If
Case 6
If durum = 1 Then
If Shape1(iaktifsekilkare(2) - 1).Visible = False And Shape1(iaktifsekilkare(2) - 11).Visible = False And iaktifsekilkare(2) > 20 Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2) - 11
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 2
End If
ElseIf durum = 2 Then
On Error Resume Next
If Shape1(iaktifsekilkare(3) + 1).Visible = False And (Not (iaktifsekilkare(3) Mod 10 = 0)) And Shape1(iaktifsekilkare(2) + 10).Visible = False Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(2)
iaktifsekilkare(1) = iaktifsekilkare(0) + 10
iaktifsekilkare(2) = iaktifsekilkare(0) + 1
iaktifsekilkare(3) = iaktifsekilkare(2) + 1
durum = 3
End If
ElseIf durum = 3 Then
On Error Resume Next
If Shape1(iaktifsekilkare(0) - 1).Visible = False And Shape1(iaktifsekilkare(1) + 10).Visible = False And (Not (iaktifsekilkare(0) Mod 10 = 1)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(0) = iaktifsekilkare(0) - 1
iaktifsekilkare(1) = iaktifsekilkare(0) + 1
iaktifsekilkare(2) = iaktifsekilkare(1) + 10
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 4
End If
ElseIf durum = 4 Then
If Shape1(iaktifsekilkare(2) + 1).Visible = False And Shape1(iaktifsekilkare(2) - 9).Visible = False And (Not (iaktifsekilkare(1) Mod 10 = 0)) Then
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = False
Next
iaktifsekilkare(2) = iaktifsekilkare(1) - 9
iaktifsekilkare(3) = iaktifsekilkare(2) + 10
durum = 1
End If
End If
End Select
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End If
End Sub
Private Sub form_load()
'şekilleri yerleştirelim
For i = 0 To 20
For k = 1 To 10
Load Shape1(10 * i + k)
If k = 1 Then
Shape1(i * 10 + k).Left = Shape1(0).Left + Shape1(0).Width
Shape1(i * 10 + k).Top = Shape1(0).Top
Else
Shape1(i * 10 + k).Left = Shape1(i * 10 + k - 1).Left + Shape1(i * 10 + k - 1).Width
Shape1(i * 10 + k).Top = Shape1(0).Top
End If
Next
Shape1(0).Top = Shape1(0).Top - Shape1(0).Height
Next
Shape2.Move Shape1(1).Left - 5, Shape1(210).Top - 5, 10 * Shape1(0).Width + 10, Shape1(0).Height * 20 + 10
Call sekilsec
For i = 0 To 10
Shape1(i).Visible = True
Next
level = 0
puan = 0
Label1.Caption = "level" & level
Label2.Caption = "punanınız:" & puan
End Sub
Private Sub sekilsec()
Randomize Timer
k = Int(Rnd * 6) + 1
Select Case k
Case 1: iaktifsekilkare(0) = 204
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 2: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 196
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 3: iaktifsekilkare(0) = 205
iaktifsekilkare(1) = 196
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 197
durum = 1
Case 4: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 196
iaktifsekilkare(3) = 206
durum = 1
Case 5: iaktifsekilkare(0) = 195
iaktifsekilkare(1) = 205
iaktifsekilkare(2) = 206
iaktifsekilkare(3) = 207
durum = 1
Case 6: iaktifsekilkare(0) = 205
iaktifsekilkare(1) = 206
iaktifsekilkare(2) = 197
iaktifsekilkare(3) = 207
durum = 1
End Select
bidaha:
renk = Int(Rnd * 15) + 1
If renk = 7 Then GoTo bidaha
For i = 0 To 3
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
End Sub
Private Sub timer1_timer()
devamet = False
For i = 0 To 3
devam(i) = False
Next
If Shape1(iaktifsekilkare(0) - 10).Visible = False Then devam(0) = True
If (iaktifsekilkare(1) - 10 = iaktifsekilkare(0)) Then
devam(1) = True
Else
If Shape1(iaktifsekilkare(1) - 10).Visible = False Then
devam(1) = True
End If
If (iaktifsekilkare(2) - 10 = iaktifsekilkare(1)) Then
devam(2) = True
Else
If Shape1(iaktifsekilkare(2) - 10).Visible = False Then
devam(2) = True
End If
If (iaktifsekilkare(3) - 10 = iaktifsekilkare(2)) Then
devam(3) = True
Else
If Shape1(iaktifsekilkare(3) - 10).Visible = False Then
devam(3) = True
End If
For i = 0 To 3
If devam(i) = True Then
devamet = True
Else
devamet = False
GoTo devamdevam
End If
Next
devamdevam:
If devamet = True Then
For i = 0 To 3
On Error Resume Next
Shape1(iaktifsekilkare(i)).Visible = False
iaktifsekilkare(i) = iaktifsekilkare(i) - 10
Shape1(iaktifsekilkare(i)).Visible = True
Shape1(iaktifsekilkare(i)).BackColor = QBColor(renk)
Next
Else
Call kontrol
Call sekilsec
End If
End Sub
Private Sub kontrol()
sil(11) = False
basla:
level = Int(puan / 1500)
Select Case level
Case 0: Timer1.Interval = 1000
Case 1: Timer1.Interval = 1000
Case 2: Timer1.Interval = 500
Case 3: Timer1.Interval = 250
Case 4: Timer1.Interval = 125
Case 5: Timer1.Interval = 60
Case 6: Timer1.Interval = 30
Case 7: Timer1.Interval = 15
Case 8: Timer1.Interval = 10
End Select
If level > 8 Then Timer1.Interval = 5
Label1.Caption = "level" & level
For i = 1 To 19
For r = 1 To 10
If Shape1(i * 10 + r).Visible = True Then
sil(r) = True
Else
sil(r) = False
End If
Next
For r = 1 To 10
If sil(r) = True Then
sil(11) = True
Else
sil(11) = False
GoTo silelim
End If
Next
silelim:
If sil(11) = True Then GoTo silbakalim
Next
Exit Sub
silbakalim:
puan = puan + 100
Label2.Caption = "puanınız:" & puan
For s = i To 19
For r = 1 To 10
If Shape1(s * 10 + r + 10).Visible = True Then
Shape1(s * 10 + r).BackColor = Shape1(s * 10 + r + 10).BackColor
Else
Shape1(s * 10 + r).Visible = False
End If
Next
Next
GoTo basla
End Sub
|
|
|
|
|
19-04-2006, 17:03
|
#9 (permalink) |
|
EN Afilli
Üyelik Tarihi: 18-12-2005
Yaş: 21
Mesajlar: 1,231
Rep Gücü: 124
Rep Puanı: 7683
|
Devam
Sayiniz tekmi çiftmi Kod:
command1_clik x=val (text1.text) if x mod 2= 0 then list2.addlitam x else list1.addlitem x end if text1.text="" end sub command2_cilik list1.clear list2.clear Mouse move ile ilgili bir örnek Kod:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Select Case Picture1.Align
Case 1
If Y < 50 Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 2
If Y > (Me.Height - 50) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 3
If X < 50 Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case 4
If X > (Me.Width - 50) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
Case Else
If Y > (Picture1.Top) And Y < (Picture1.Top + Picture1.Height) Then
Picture1.Visible = True
Else
Picture1.Visible = False
End If
End Select
End Sub
Hesap makinesi Kod:
Dim sonuc, durum, durum2, durum3, islem, adet Private Sub hafiza(durum) Static sayi, toplam Select Case durum Case 1: toplam = toplam + sayi Case 2: sayi = Val(Giris) Case 3: Giris = Str(Giris) + Str(sayi) Case 4: sayi = 0 End Select End Sub Private Sub Btn0_Click() Giris = Giris + "0" End Sub Private Sub Btn1_Click() If durum = 0 Or durum3 = 0 Then Giris = "1" Else Giris = Giris + "1" End If durum = 1 durum3 = 1 adet = 0 End Sub Private Sub Btn2_Click() If durum = 0 Or durum |