1-) Projelerinize Referans ve Bileşen Eklemek

* Giriş

Visual Basic menülerinde References ve Components diye iki tane komut mutlaka görmüşsünüzdür. Bu komutlar ileri seviye bir projenin bel kemiğidir; zira standart bir EXE projesi açtığınızda sadece Visual Basic' in size sunduğu Temel Form Elemanları (textbox,label,dropbox vs) bulunur. Bir proje bunlardan daha fazlasına ihtiyaç duyduğunda devreye References ve Components komutları giriyor.

Şekil.1 - Standart EXE Project Açıyoruz

Visual Basic ile "Standart Exe Project" açtığınızı varsayıyorum ve anlatımıma bu şartlar altında devam ediyorum (Şekil.1).

* Components Komutu ve Bileşen Ekleme

Projemiz yüklendiğinde ToolBox adı verilen pencerede kullanılabilir nesnelerin simgelerini göreceksiniz (Şekil.2). Bu nesneleri ek bir işlem yapmadan projenizde kullanma hakkına sahipsiniz. Asıl mesele bu penceredekilerle göremediğiniz işlerinizde ortaya çıkıyor.


Diyelim ki, bir sohbet programı yapacaksınız. Bu iş için MS Winsock bileşenine ihtiyaç duyacaksınız. ToolBox içinde yer almayan bu nesneyi kullanılabilir duruma getirebilmek için Visual Basic Menüsü'nden Project -> Components komutuna ihtiyacınız olacak. ToolBox penceresine sağ tıklayarak da Components komutuna ulaşabilirsiniz. Components komutundan sonra karşımıza gelen pencerede bir liste belirecek. İşte bu liste elemenları bilgisayarımızda kurulu bulunan bileşenlerdir. Liste elemanları herkeste çeşitlilik gösterebilir ve emin olun gösterecektir (Şekil.3).

* References Komutu ve Referans Ekleme

Referans eklemenin bileşen eklemekten hiçbir farkı yoktur. Ancak referanslarla bileşenlerin kullanım şekilleri farklıdır. Yukarıda anlattığım bileşenleri projelerde tasarım aşamasında kullanırsınız. Fiziksel bir görünüşleri vardır. Kullanımları da o yüzden çok kolaydır. Referanslar bu bileşenlerin kullandıkları altyapıyı projelerinize entegre etmenizi sağlar. Örneğin MS Winsock nesnesinin referansını projenize dahil etmiş olsaydınız ToolBox içinde bir nesne belirmeyecekti. Buna rağmen birtakım kod kombinasyonları ile bir MS Winsock nesnesi yaratıp sanki form üzerinde bir MS Winsock nesnesi varmış gibi kullanabilirdiniz.

Şimdi ben burada sadece referansların projelere nasıl dahil edildiklerinden bahsediyorum. Kullanımları, avantajları ya da dezavantajlarını da size ayrı bir konu başlığı olarak sunmak daha mâkul olacaktır.

Örnek olarak Microsoft DAO 3.6 Object Library referansını en başta açtığımız projeye ekleyeceğim. Visual Basic Menüsü'nden Project -> References komutunu verelim. Açılan penceredeki listeden bu referansı bulup seçili duruma getirelim. En son olarak da OK düğmesi ile referansı resmen projemize dahil edelim (Şekil.5).

Visual Basic'de Dosya Kayıt Etmek;

ilk olarak forma 3 adet textbox ve 1 adet command button ekleyin. Daha sonra aşağıda verilen kodu formun içine yapıstırın...smile.gif

Kod:

Private Sub Command1_Click()
Open "deneme.dat" For Output As #1
Write #1, Text1.Text
Write #1, Text2.Text
Write #1, Text3.Text
Close #1
End Sub

Private Sub Form_Load()
Open "deneme.dat" For Binary As #1
Close #1
Open "deneme.dat" For Input As #1
If LOF(1) = 0 Then GoTo sona
Input #1, a
Input #1, b
Input #1, c
sona:
Close #1

Text1.Text = a
Text2.Text = b
Text3.Text = c

End Sub

Kodun çalışma mantığı şu :

İlk olarak açıldığında "deneme.dat" isimli dosyayı açıyor eğer yoksa yaratıyor.
Daha sonra textboxa girilen bilgileri commandbuttona basıldığında "deneme.dat" dosyasına kayıt ediyor ve program tekrar açıldığında dosyadaki bilgiyi okuyup textboxları dolduruyor.

Baş Harfler Otomatik Büyüsün

Visual Basic'de bir TextBox ile yazdığınız programlar için başharflerinin otomatik büyümesini sağlayacak bir kod; Form'a bir CommandButton ve TextBox koyun.
ve ardından ;

Kod:

Private Sub Command1_Click()
Text1 = StrConv(Text1,vbProperCase)
End Sub

Bu kod sayesinde yazılan her kelimenin başharfi büyük olacaktır.

'Kullanışlı Bir Module

'Yeni bir module açın ve option explicitten itibaren module ün içine yapıştırın.

Özellikler
*PlaySound dosyaismi.uzantı - wav ya da midi çalar
*CDOpen - Cd-Romu Açar
*CDClose - Cd-Romu Kapatır
*UnloadAllForms - Bütün Formları Kapatır
*SaveText textboxadı,dosyaadı - textboxı dosyaya kaydeder
*LoadText textbox,dosyaadı - dosyadan textboxa yükler
*HangUp - Internet bağlantısını Keser

'Bu Kısım Module İçine Yazılacak!

Kod:

Option Explicit

Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasHangUp Lib "RasApi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long

Const RAS95_MaxEntryName = 256
Const RAS95_MaxDeviceType = 16
Const RAS95_MaxDeviceName = 32

Const RAS_MAXENTRYNAME As Integer = 256
Const RAS_MAXDEVICETYPE As Integer = 16
Const RAS_MAXDEVICENAME As Integer = 128
Const RAS_RASCONNSIZE As Integer = 412

Private Type RasConn
dwSize As Long
hRasConn As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
szDeviceType(RAS_MAXDEVICETYPE) As Byte
szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type
Public Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
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
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long


Public Sub PlaySound(strFileName As String)
sndPlaySound strFileName, 1
End Sub


Sub CDOpen()
Dim OpenCD$
OpenCD$ = mciSendString("set CDAudio door open", vbNullString, 0, 0)
End Sub


Sub CDClose()
Dim CloseCD$
CloseCD$ = mciSendString("set CDAudio door closed", vbNullString, 0, 0)
End Sub


Public Sub UnloadAllForms()
Dim Form As Form
For Each Form In Forms
Unload Form
Set Form = Nothing
Next Form
End Sub

Sub SaveText(thatxt As TextBox, File As String)
On Error GoTo Error
Dim mystr,X As String
Open File For Output As #1
Print #1, thatxt
Close 1
Exit Sub
Error:
X = MsgBox("Kaydetme Hatası", vbOKOnly, "Hata")
End Sub

Sub LoadText(thatxt As TextBox, File As String)
On Error GoTo Error
Dim mystr,X As String
Open File For Input As #1
Do While Not EOF(1)
Line Input #1, a$
texto$ = texto$ + a$ + Chr$(13) + Chr$(10)
Loop
thatxt = texto$
Close #1
Exit Sub
Error:
X = MsgBox("Yükleme Hatası", vbOKOnly, "Hata")
End Sub


Public Sub HangUp()
On Error Resume Next

Dim lpRasConn(255) As RasConn
Dim lpcb As Long
Dim lpcConnections As Long
Dim hRasConn As Long
Dim nLoop As Long

lpRasConn(0).dwSize = RAS_RASCONNSIZE
lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
lpcConnections = 0

If RasEnumConnections(lpRasConn(0), lpcb, lpcConnections) = 0& Then
For nLoop = 0 To lpcConnections - 1
If Trim(ByteToString(lpRasConn(nLoop).szEntryName)) <> "" Then
hRasConn = lpRasConn(nLoop).hRasConn
RasHangUp ByVal hRasConn
End If
Next
End If
End Sub

Public Function ByteToString(bytString() As Byte) As String
Dim nLoop As Integer
ByteToString = ""
nLoop = 0
While bytString(nLoop) = 0&
ByteToString = ByteToString & Chr(bytString(nLoop))
nLoop = nLoop + 1
Wend
End Function

Analog Saat

'Merhaba Arkadaslar Yeni Bir Form Acin icine birtane
'HScrollBar ekleyin Ismi HScroll1 olsun. 'PictureBox Ekleyin ismi Picture1 olsun
'Picture1'in icine Shape yerlestirin (Daire Seklinede) ismi Shape1 olsun
'En sonunda da Line(Cizgi) ismide linclock olsun indexi ni de (0)(sifir verin)
'Enazindan bu uygulamada boyle
'Ve asagidaki Kodu Formun icine paste edin

Kod:

Dim Angle
Private Sub Form_Load()
Picture1.Scale (-1, -1)-(1, 1)
'SwH Presents Umarim Bir cok sey cikartabilirsiniz
End Sub
Private Sub HScroll1_Change()
Angle = -0.05 * (700 - HScroll1.Value)
linclock(0).X1 = 0
linclock(0).Y1 = 0
linclock(0).X2 = 0.8 * Cos(Angle)
linclock(0).Y2 = 0.8 * Sin(Angle)
End Sub

FORMUNUZ HEP ÜSTE DURSUN

'Aşağıdaki verdigim kodLarı formun code sayfasına yapıştırın
'Kolay Gelsin smile.gif

Kod:

'""""""""""""""""""""
CODE
Const HWND_TOPMOST = -1 ' Hep üstte tutan değişken değer
Const HWND_NOTOPMOST = -2 ' Hep üstte özelliğini yok eden değişken değer...
Const SWP_NOSIZE = &H1 ' Formun boyutlarını değiştirilmez yapar...
Const SWP_NOMOVE = &H2 ' Formu taşınmaz yapar...
Const SWP_NOACTIVATE = &H10 ' Form Aktif yapılmaz...
Const SWP_SHOWWINDOW = &H40 ' Pencere Görünür Yapılır...
Private Declare Sub SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

Private Sub Form_Activate()

SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE _
Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE

End Sub

Ağ Sürücüsüne Bağlanmak Ve Bağlantıyı Kesmek

Merhabalar
Projenize 2 adet command butonu ekleyin ve aşağıdaki kodları formun code sayfasına yapıştırın .Kolay Gelsin..

'""""""""""""""""""""
CODE
Private Declare Function WNetConnectionDialog Lib "mpr.dll" (ByVal hwnd As Long, ByVal dwType As Long) As Long
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" (ByVal hwnd As Long, ByVal dwType As Long) As Long
Private Const RESOURCETYPE_DISK = &H1, RESOURCETYPE_PRINT = 0
Dim x As Long
Private Sub Command1_Click()
x = WNetConnectionDialog(Me.hwnd, RESOURCETYPE_DISK)
End Sub
Private Sub Command2_Click()
x = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_DISK)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
MsgBox "Omerbicici@yahoo.com", vbInformation + vbOKOnly, "Mail Adresim"
End Sub
Private Sub Form_Load()
Command1.Caption = "Bağlan"
Command2.Caption = "Bağlantıyı Kes"
End Sub

Vscroll Kullanımı

Formunuza 3 adet VScroll ekleyin. Bir de textbox yerleştirin.

Kod:

Private Sub Form_Load()
VScroll1.Max = 255
VScroll2.Max = 255
VScroll3.Max = 255
End Sub

Private Sub VScroll1_Change()
Text1.BackColor = RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub

Private Sub VScroll2_Change()
Text1.BackColor = RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub

Private Sub VScroll3_Change()
Text1.BackColor = RGB(VScroll1.Value, VScroll2.Value, VScroll3.Value)
End Sub

İstediğin dosya senin programınla açılsın

Çoğu Visual Basic sitelerinin forumlarında kullanıcıların Association, yani belirli bir uzantıya sahip dosyaları kendi hazırladıkları programla nasıl çalıştırabilecekleri konusunu bilmedikleri, bu konu hakkında yardım istedikleri fakat tatmin edici sonuca ulaşamadıklarını gözlemliyorum. Bu nedenle Association konusuna açıklık getirecek bu dokümanı yazıp konu ile ilgilenenlerin hizmetine sunmaya karar verdim.

Öncelikle öğrenmemiz gereken en temel bilgi çoğu konunun olduğu gibi bu konunun da çözümünün Registry (Kayıt) dosyalarında yattığıdır. Dokümanın sonunda hem Association konusunu, hem de bir nebze de olsa Registry'e API kullanarak kayıt yazmayı öğreneceğiz.

Örneğimize başlamamız için kendimize bir dosya uzantısı, bir de bu uzantıdaki dosyaları açacak program seçmeliyiz. Ben dokümanda örnek teşkil etmesi için dosya uzantısı olarak ".asp", program olarak ta kendi yazdığım "ASP Anahtarı" isimli programı seçtim. İşe başlamadan önce projemizde "Registry" bir modül oluşturarak aşağıdaki API tanımlamalarını bu modül içerisine yerleştirelim ve kaydedelim.

CODE

Kod:

Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const REG_SZ = 1

Public Sub RegKaydiYaz(hKey As Long, Anahtar As String, DegerAdi As String, Deger As String)
Dim Ac 'Oluşturulacak anahtarın adresi
RegCreateKey hKey, Anahtar, Ac 'Anahtarı oluşturduk
RegSetValueEx Ac, DegerAdi, 0, REG_SZ, ByVal Deger, Len(Deger) 'Anahtarımızın "DegerAdi" isimli değerine "Deger" parametresi ile gelen String değeri atadık.
RegCloseKey Ac 'Ve açtığımız anahtarı kapattık.
End Sub

Registry isimli modülü oluşturduysanız devam edebiliriz. Dosya uzantılar ve bunları açacak programlarla ilgili bilgiler Registry'nin HKEY_CLASSES_ROOT anahtarı altında yer alırlar. Windows'un RegEdit Programını kullanarak bu anahtarı açtığımızda önümüze ilk önce dosya uzantıları sıralanır. Biz bu dosya uzantıları arasından kendi programımızla açmak istediğimiz uzantıyı buluyoruz. Eğer istediğimiz uzantı burada bulunmuyorsa hemen oluşturuyoruz. Bunun için formumuzun Load olayına aşağıdaki kodları ekleyip (isterseniz) programımızı Run>Start menüsü (ya da klavyenin F5 tuşu) ile çalıştıralım.


Eğer kaydetmek istediğimiz uzantı daha önce Registry kayıtlarında mevcut ise RegEdit'i kullanarak bu kaydın değerlerini bir kenara kaydedin. Aksi halde bu işin geri dönüşü olamayabilir.

Kod:

Private Sub Form_Load()

'RegKaydiYaz(hKey As Long, Anahtar As String, DegerAdi As String, Deger As String)
RegKaydiYaz HKEY_CLASSES_ROOT, ".asp", "", "ASPAnahtari"

End Sub

İstediğiniz hızda Exe dosyası çalıştırın!

Bu kod sayesinde bir exe dosyasını istediğiniz hızda (düşük, normal, yüksek, gerçek zaman) çalıştırabiliyorsunuz. Aşağıdaki kodu bir modül yaparak modülün içine yapıştırın.Modülün adı Module 1 olsun yani değiştirmeyin…

Kod:

Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long

Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Const PROCESS_QUERY_INFORMATION = &H400

Enum Priority

    High = &H80

    RealTime = &H100

    Normal = &H20

    Idle = &H40

End Enum

Enum ProgState

    NormalFocus = vbNormalFocus

    MaximizedFocus = vbMaximizedFocus

    MinimizedFocus = vbMinimizedFocus

    Hidden = vbHide

End Enum





Public Function Run(ExeFileName As String, Optional ProcessPriority As Priority = &H20, Optional ProgramState As ProgState = vbNormalFocus) As Boolean

Dim hProcess As Long

hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(ExeFileName, ProgramState))

SetPriorityClass hProcess, ProcessPriority

Dim I As Long, S As String

I = GetPriorityClass(hProcess)

If I <> ProcessPriority Then GoTo ER:

Run = True

Exit Function

ER:

Run = False

End Function

Daha sonra yeni bir form oluşturun forma bir command buton ekleyin ve aşağıdaki kodu forma yapıştırın:


CODE

Kod:

Private Sub Command1_Click()

Module1.Run "C:\WINDOWS\NOTEPAD.EXE", Normal, MaximizedFocus

End Sub

Bu kod ile Not defteri çalışırılıyor…

Visual Basic.NET - TARİH SAAT FONKSİYONLARI

Arkadaşlar Merhaba!

Son hızla devam ediyoruz ;

TARİH SAAT FONKSİYONLARI

Visual Basic.NET de , tarihi saati , hangi gün veya hangi ayda olduğumuzu öğrenmek için bu fonksiyonları kullanırız.


1. Now()

Bu fonksiyon , şu anki tarih saat bilgisini verir. Tabiki tüm tarih saat fonksiyonları sistem saatini kullandığı için , bilgisayarınızda o an hangi tarih saat geçerli ise , o değeri döndürecektir.

Örnekler :

Msgbox(Now())

Label1.Text = Now()

2. Day(deger)

Bu fonksiyon deger olarak belirtilen tarihin gününü döndürür. Deger olarak belirtilen değişken geçerli bir tarih olmalıdır.

Örnekler :

Day(12.10.2006) = dönen değer 12 olacaktır.

Day(Now()) = bugünün gün değeri dönecektir.

3. Weekday(date[, firstdayofweek])

Bu fonksiyon date değişkeni ile belirtilen tarihin , haftanın kaçıncı günü olduğu değerini döndürür. İkince değişken ise isteğe bağlı olup haftanın ilk gününü ayarlamak için kullanılır. İngilizce işletim sistemine sahip bir bilgisayarda haftanın ilk günü Pazar olacaktır ama Türkçe işletim sistemine ait bir bilgisayarda haftanın ilk günü pazartesi olacaktır.

Bu fonksiyon haftanın günlerini 1 den 7 ye kadar numaralandırarak seçili olan günü geri döndürür. Pazartesi 1 , Salı 2 , Çarşamba 3 ….. şeklinde devam etmektedir.

Örnekler :

MsgBox(Weekday(Now, FirstDayOfWeek.System)) = burada bugün Cuma olduğu için 5 değeri dönecektir. Haftanın ilk günü ayarını ise işletim sistemine bıraktım.

4. WeekdayName(weekday[, abbreviate[, firstdayofweek]])

Bu fonksiyon , weekday değişkeni ile belirtilen günün ismini döndürür. Abbreviate değişkeni ilede , gün isminin kısamı uzunmu gösterileceği ayarlanır. ( Paz, Pzt , Salı , Cuma gibi ) . Üçüncü değişken diğer fonksiyonda olduğu gibi haftanın ilk gününü ayarlamak için kullanılmaktadır.

Örnekler :

MsgBox(WeekdayName(5, False, FirstDayOfWeek.System)) = Dönen değer -> Cuma
MsgBox(WeekdayName(5, True, FirstDayOfWeek.System)) = Dönen değer -> Cum




5. Month(date)

Bu fonksiyon date değişkeni ile belirtilen tarihin , yılın kaçıncı ayı olduğu değerini döndürür. Ocak = 1 , Şubat = 2 , Mart = 3 şeklinde , 1 den 12 ‘ye kadar integer değer döndürür.

Örnekler :

Month(Now()) = Dönen değer = 7 olacaktır. Temmuz yılın 7 nci ayıdır.

6. MonthName(month[, abbreviate])

Bu fonksiyon ile month ile belirtilen ( 1 den 12 ye kadar ay numaraları ) ayın ismini döndürür. İkinci değişken isteğe bağlı olup , dönen ay adının uzunmu yoksa kısamı olacağını ayarlamaya yarar.

Örnekler :

Msgbox(MonthName(7)) = Dönen değer Temmuz olacaktır.

7. Year(date)

Bu fonksiyon , date değişkeni ile belirtilen tarihin yıl değerini döndürür.

Örnekler :

Msgbox(Year(Now()) = dönen değer 2006 olacaktır.

8. Hour(time)

Bu fonksiyon ile , time değişkeni ile belirtilen zamanın saat değer 0 dan 24 ‘e kadar olan integer türünden bir değer döndürür.

Örnekler :

Now() = fonksiyonu 14.07.2006 11:28:30 değerinin döndürürken
Hour(Now()) fonksiyonu = 11 değerini döndürür


9. Minute(time)

Bu fonksiyon ile , time değişkeni ile belirtilen zamanın dakika değeri , 0 dan 60 a kadar olan integer türünden bir değer döndürür.

Örnekler :

Now() = fonksiyonu 14.07.2006 11:28:30 değerinin döndürürken
Minute(Now()) fonksiyonu = 28 değerini döndürür

10. Second(time)

Bu fonksiyon ile , time değişkeni ile belirtilen zamanın saniye değeri , 0 dan 60 a kadar olan integer türünden bir değer döndürür.

Örnekler :

Now() = fonksiyonu 14.07.2006 11:28:30 değerinin döndürürken
second(Now()) fonksiyonu = 30 değerini döndürür


11. DateSerial(year, month, day)

Bu fonksiyon dışarında 3 değişken ile integer türünden bir veri almakta ve girilen sayıları tarih olarak geri döndürmektedir.

MsgBox(DateSerial(2005, 7, 1)) şeklinde bir fonksiyon 01.07.2005 olarak geri dönecektir.

Bu fonksiyonun kullanım yeri sadece bunula sınırlı değildir. Herhangi bir yılın 90 ncı günü, hangi tarihe geliyor diye merak ediyorsanız yapmanız gereken tek şey aşağıdaki gibi bir fonksiyon kurmak ;

DateSerial(1996, 1, 90)

1996 yılının 90 ncı günü nedir gibi bir fonksiyonun dönen değeri = 30.03.1996 olacaktır.

Bir başka kullanım şeklide; mesela bugünden sonra 1000 nci gün hangi tarihe gelir gibi bir soruya cevabı aşağıdaki fonksiyon verecektir;

MsgBox(DateSerial(Year(Now. Date), Month(Now. Date), Weekday(Now. Date) + 1000))

Eğer bugünü 14.07.2006 olarak kabul edersek dönen değer = 01.04.2009 olacaktır.

Aynı şekilde yıl, ay içinde toplama ve çıkartma işlemlerini kullanarak, istediğimiz bir tarihi bulabiliriz.

12. DateValue(date)

Bu fonksiyon string olarak girilen tarih değerini normal tarihe çevirir.

Örnekler;

DateValue(“12 Kasım 2007” ) fonksiyonu 12.10.2007 olarak geri dönecektir.

Bu fonksiyonun güzel bir özelliğide, iki tarih arasında kaç gün olduğunu öğrenmek içinde kullanılabilir. Finansal programlar için DateSerial kadar iyi bir fonksiyondur.

MsgBox(DateDiff(DateInterval. Day, DateValue(“25.12.1993”), DateValue(“25.12.1996”)))

Bu şekilde kullanılan bir fonksiyon ile 25.12.1993 ve 25.12.1996 tarihleri arasında kaç gün olduğunu öğrenebiliriz. Dönen değer 1096 gün olacaktır.

13. TimeSerial(hours, minutes, seconds)

Bu fonksiyon DateSerial fonksiyonu gibi çalışmakta , yalnız tek farkı tarih üzerinde değil , zaman üzerinde çalışmasıdır. Dışarıdan girilen 3 değişkeni zaman olarak geri döndürür.

TimeSerial(4, 10, 55) = dönen değer = 04:10:55 oalcaktır.

Yine Dateserial fonksiyonunda olduğu gibi , saat dakika ve saniyede çıkartma toplama gibi işlemler yaparak , istediğimiz bir saati bulmamız mümkündür

TimeSerial(16 - 2, 13 - 15, 40 - 32) = dönen değer 13:58:08 olacaktır.

14. TimeValue(time)

Bu fonksiyonda DateValue() fonksiyonu ile aynı özelliklere sahiptir.




15. DateAdd(interval, number, date)

Bu fonksiyon, interval değişkeni ile belirtilen tarihe, number değişkeni ile belirtilen değeri ekler. İnterval değişkenin alabileceği değerler şunlardır;

Year
Quarter
Month
DayOfYear
Day
WeekDay
WeekOfYear
Hour
Minute
Second

DateAdd(DateInterval.Month, 1, Now)= bu fonksiyon ile , bir sonraki ay değeri dönecektir. 14.08.2006 11:20:00 şeklinde değer dönecektir.

16. DateDiff(interval, date1, date2[, firstdayofweek[, firstweekofyear]])


Bu fonksiyon ile , iki tarih arasındaki farkı almamız münkün. İnterval özelliği ile ( bir önceki listede var), iki tarih arasındaki hangi farkı almak istiyorsak onu ayarlarız. Date1 ve date2 değişkenleri ile tarih farkı alınacak olan değerler belirtilir. Diğer iki değişen isteğe bağlı olup system olarak seçilebilir.

Örnekler ;

Mesela ben doğalı kaç gün olmuş gibi bir hesap için ;
Dim dogumtarihi As Date = "16.09.1979"
MsgBox(DateDiff(DateInterval.Day, dogumtarihi, Now()))

17. DatePart(interval, date[,firstdayofweek[, firstweekofyear]])

Bu fonskiyon ile , date değişkeni ile belirtilen bir tarihin , istediğimi bilgisine ulaşabiliriz. İnterval değişkeni ise , aşağıdaki tabloda belirtilen şekilde kullanılmalıdır.

Karakter Açıklaması
: Saat , dakika , saniyeyi ayrımak için kullanılır
/ Gün , ay , yılı ayırmak için kullanılır.
D Belirtilen günün numarasını verir. (1–31).
dd Belirtilen günün numarasını verir , tek numaraların başına 0 ekler. (01–31).
ddd Gün isimlerinin kısaltmalarını verir. (Paz , Sal gibi).
dddd Gün isimlerinin tam adını görüntüler (Pazar , Salı gibi).
w Günün haftanın kaçıncı günü olduğunu gösterir. (1- 7 arası).
Ww Yılın kaçıncı haftası olduğunu gösterir. (1–54).
M Belirtilen tarihin ay numarasını verir. ( 0 – 12 arası )
MM Belirtilen tarihin ay numarasını verir. Tek rakamların önüne 0 koyar( 01 – 12 arası )
MMM Kısa ay adlarını gösterir (Oca. , Şub gibi).
MMMM Ayların tam adını görüntüler (Ocak , Şubat gibi).
q Yılın kaçıncı çeyreğinde olduğunu gösterir. (1–4).
y Yılın kaçıncı günü olduğunu gösterir. (1–366).
yy Yıl numaralrının iki rakamlı gösterir. (00–99).
yyyy Yıl numaralarını 4 rakamlı gösterir. (0100–9999).
h Saati gösterir (0–12).
Hh Saati iki rakamlı gösterir. (00–12).
H 24 saat formatına göre saati gösterir. (0–24)
HH 24 saat formatına göre saati 2 rakamlı gösterir. (00–24)
m Dakikayı gösterir. (0–59).
mm Dakikayı iki rakamlı gösterir. (00–59).
s Saniyeyi gösterir. (0–59).
ss Saniyeyi iki rakamlı gösterir. (00–59).


Örnekler ;

Dim tarih as DateTime = Now() -- > değerin 14.07.2006 12:25:50 olduğunu varsayalım


DatePart(“yyyy”, tarih)) = dönen değer 2006 olacaktır
DatePart(“q”, day1)) = dönen değer 3 olacaktır. Temmuz ayı yılın 3 ncü çeyreği içindedir.( Ocak-Şubat-Mart = 1 / -Nisan-Mayıs-Haziran = 2 / Temmuz-Ağustos-Eylül = 3 ……….gibi)
DatePart(“m”, day1)) = dönen değer 7 olacaktır.

PC adı ve K.Adı Bulma

formumuza 2 adet textbox yerle
ştiriyoruz ve kodu yazıyoruz

Option Explicit
Private S1 As String
Private Declare Function GetUser Lib "mpr.dll" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function FindUserName() As String
S1 = Space(512)
GetUserName S1, Len(S1)
FindUserName = Trim$(S1)
End Function
Public Function FindNetUserName() As String
S1 = Space(512)
GetUser vbNullString, S1, Len(S1)
FindNetUserName = Trim$(S1)
End Function
Public Function FindComputerName() As String
S1 = Space(512)
GetComputerName S1, Len(S1)
FindComputerName = Trim$(S1)
End Function
Private Sub Form_Load()
Dim ComputerName, ComputerUser
ComputerUser = FindNetUserName
Text1.Text = ComputerUser
Text2.Text = FindComputerName
End Sub

MSN PROGRAM

Dim a As String
Private Sub Command1_Click()
ww.RemotePort = 808
ww.RemoteHost = Text1
ww.Connect
End Sub
Private Sub Command2_Click()
With ww
.LocalPort = 808
.Listen
End With
End Sub
Private Sub Command3_Click()
ww.SendData Text2
Label2 = "gönderildi"
End Sub

TEXT Kutusuna Sadece Sayı Girme.

Kod:

[color=red]'Textbox nesnesine sadece rakam girmek için;
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim karakter$
karakter = "0123456789"
If KeyAscii <> 8 Then
If InStr(karakter, Chr(KeyAscii)) = 0 Then
Beep
KeyAscii = 0
Exit Sub
End If
End If
End Sub
'Burada karakter değişkenine hangi değerler atanırsa text kutusunu o değerler girilebilir.'Örneğin karakter="abc" yazılırsa text kutusuna sadece a,b ve c harfleri girilebilir[/color].

Windows Calculate Benzeri Hesap Makinesi
İndirmek için
[Linkleri görebilmek için üye olun veya giriş yapın.]

Memory Write

forma

1 adet commandbutton
1 adet textbox

Kod:

Private Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Private Declare Function GetWindowThreadProcessId Lib "User32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal Classname As String, ByVal WindowName As String) As Long
Private Declare Function ReadProcessMem Lib "kernel32" Alias "ReadProcessMemory" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long


Public Function MemoryWrite(Offset As Long, WindowName As String, Value As Long) As Boolean

Dim hwnd As Long
Dim ProcessID As Long
Dim ProcessHandle As Long


hwnd = FindWindow(vbNullString, WindowName)

If hwnd = 0 Then '
MsgBox "Oyun açık değil!", vbCritical, "Yazma Hatası" 'oyun acıkdeyilse bu hatayı versin isterseniz silebilirsiniz

Exit Function

End If

GetWindowThreadProcessId hwnd, ProcessID

ProcessHandle = OpenProcess(PROCESS_ALL_ACCESS, False, ProcessID)

If ProcessHandle = 0 Then

Exit Function

End If

WriteProcessMemory ProcessHandle, Offset, Value, 4, 0&
CloseHandle ProcessHandle


End Function

kullanılısı

forma bu kodu yapıstır

Kod:

Private Sub Command1_Click()
MemoryWrite &H41D090, "prog test", Text1.Text
End Sub

Private Sub Form_Load()
Text1.Text = "100"
End Sub

1- prog test

Animasyonlu Button

Kod:

'Kullanılan Nesneler
'CommandButton

Private Sub Form_Load()
  command1.Caption="BAŞLA BAKALIM
End Sub

Private Sub Command1_Click
  Dim j,k
  For k=1 to 800
  For j=1 to 50
      Command1.Caption=j
  Next
  Next
End Sub

Analog Saat Yapımı

iki adet timer ekleyin kodu direk yapıştırın

--------------------------------

Kod:

Private Sub Form_Load()
Dim aci, i, t
AutoRedraw = True
Timer1.Interval = 1000 ' 1 saniye
Timer2.Interval = 10 '1 saniye
'zemin desenini çiz
ScaleMode = 3 'pixel moduna geçir
For i = 0 To ScaleHeight
Line (0, i)-(ScaleWidth, i), i * 256
Next
ScaleMode = 1 'normal moda dön
'form yüksekli?ini ve genisligini ayni yap
Width = ScaleHeight
'matematiksel koordinatlara göre yeniden ölçekle
Scale (-20, 20)-(20, -20)
t = "Geveze.Forum7.Biz"
CurrentX = -TextWidth(t) / 2 ' orta noktayy bul
CurrentY = -1
Print t
t = "    KrcGk  "
CurrentX = -TextWidth(t) / 2
CurrentY = -4
Print t
 
'saat yuvarlagini ciz
DrawWidth = 5
Circle (0, 0), 19, 65535
 
DrawWidth = 2
'saniye cizimlerini ciz
For aci = 0 To 360 Step 6
Line (18 * Cos(aci * 3.1415 / 180), 18 * Sin(aci * 3.1415 / 180))-(19 * Cos(aci * 3.1415 / 180), 19 * Sin(aci * 3.1415 / 180)), QBColor(5) 'saniyelerin arka rengi
Next
'saat cizgilierini ciz
DrawWidth = 4
For aci = 0 To 360 Step 6 * 5
Line (18 * Cos(aci * 3.1415 / 180), 18 * Sin(aci * 3.1415 / 180))-(19 * Cos(aci * 3.1415 / 180), 19 * Sin(aci * 3.1415 / 180)), QBColor(15) 'saatlerin arka rengi
Next
DrawMode = 7 'xor
End Sub
 
Private Sub Timer1_Timer()
Dim aci, saniye, dakika, saat, i
Static sx, sy, dx, dy, stx, sty
Caption = Time
DrawWidth = 2
Line (0, 0)-(sx, sy), QBColor(6) 'saniyeyi çiz
saniye = Second(Time) 'saniyeyi saatten al
aci = -saniye * 6 + 90 'her bir saniye +6 derecedir 360 derece 60 saniyedir
sx = 18 * Cos(aci * 3.1415 / 180)
sy = 18 * Sin(aci * 3.1415 / 180)
Line (0, 0)-(sx, sy), QBColor(6) 'saniyeyi çiz
 
DrawWidth = 3
Line (0, 0)-(dx, dy), QBColor(11) 'yelkovany çiz
dakika = Minute(Time) 'dakikayi saatten al
aci = -dakika * 6 + 90 'her bir dakika 6 derecedir 360 derece / 60 dakikadir
dx = 18 * Cos(aci * 3.1415 / 180)
dy = 18 * Sin(aci * 3.1415 / 180)
Line (0, 0)-(dx, dy), QBColor(11) 'yelkovani çiz
DrawWidth = 3
Line (0, 0)-(stx, sty), QBColor(12) 'akrebi ciz
saat = Hour(Time) 'saati saatten al
aci = -saat * 30 + 90 'her bir saat 30 derecedir 360 derece / 12 saat
stx = 12 * Cos(aci * 3.1415 / 180)
sty = 12 * Sin(aci * 3.1415 / 180)
Line (0, 0)-(stx, sty), QBColor(12) 'akrebi ciz
'saat basi ise zil cal
If Minute(Time) = 0 Then Beep
End Sub
 
Private Sub Timer2_Timer()
Static sls
sls = (sls + 1) Mod 360
Dim aci
Dim sx, sy, dx, dy, stx, sty
DrawWidth = 1
aci = -sls * 3.6 + 90 'her bir saniye 3.6 derecedir. 360 derece/ 100
sx = 3 * Cos(aci * 3.1415 / 180)
sy = 3 * Sin(aci * 3.1415 / 180)
Line (5, 5)-(5 + sx, 5 + sy), QBColor(10) 'sagdaki kucuk ibre
Line (-5, 5)-(-5 - sx, 5 - sy), QBColor(10) 'soldaki kucuk ibre
End Sub

Hoşgeldin blinko:)

CD-ROM'u kontrol etmek hiç bu kadar kolay olmadı

Kod;

QUOTE
Private Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Private Sub Command1_Click()
mciExecute ("set cdaudio door open")
End Sub
Private Sub Command2_Click()
mciExecute ("set cdaudio door closed")
End Sub

VB'de mp3 player yapmak için ilk önce components bölümünden (ctrl+T tuş kombinasyonu ile ulaşabilirsiniz) windows media player componentini ekleyin.Daha sonra bir text kutusu ve bir command button koyun daha sonra commandın içine

CODE
mediaplayer1.filename=text1.text mediaplayer1.play
yazın.
Daha sonra text kutusuna herhangi bir mp3 parçasının yolunu yazın sonra komut düğmesine tıklayın. Böylece basit bir mp3 çalar yapmış olduk. bu işin temel mantığı budur.
Şarkıyı durdurmak için;
CODE
mediaplayer1.stop

sesi kapatmak için;
CODE
mediaplayer1.mute=true

sesi azaltmak için;
CODE
mediaplayer1.volome=mediaplayer1.volome-5

art için;
CODE
mediaplayer1.volome=mediaplayer1.volome+5
şeklinde kodlar yazabilirsiniz.

Daha sonra bu programa mp3 klasörü ekle,sadece şarkı ekle gibi winampta bulunan menüler ekleyebilirsiniz.
Ana pencerede iki tane liste olduğunu varsayarsak birinci listeye;
CODE
mediaplayer1.filename

ikinci listeye;
CODE
dir1.path & "\" &mediaplayer1.filename

kodları ile mp3 şarkılarını aktarın yani birine şarkı adı diğeine de şakı yolu. ve listlerin ineexlerini eşitlersek şarkı adına tıkladığımızda diğer taraftan da şarkının asıl yoluna otomatik olarak tıklamış oluruz. önceden text kutusuyla yaptığımız işi şimdi listeyle yapalım bunun için list2'nin dblclick olayına;
CODE
mediaplayer1.filname=list2.text mediaplayer1.play

komutunu eklersek list1 de tıkladığımız şarkı list2 deki yolu alarak çalar . İşte tüm hikaye böyle.

Dosyalama İşlemi

İlk olarak projenizde 3 adet form olaması gerekiyor.

-------------------------------------------------
1. form için kodlar. Forma 2 command ekleyin.
/////////////////////////////////////////////////
Private Sub Command1_Click()
Form2.Show 'form 2yi görüntüle
End Sub

Private Sub Command2_Click()
Form3.Show 'form 3ü görüntüle
End Sub
/////////////////////////////////////////////////


--------------------------------------------------
2.form için kodlar. Forma 4'er adet label ve textbox ekleyin. Label1-Text1 'in karşısına gelecek şekilde olsun. Diğerleride aynen. 1 tane de command ekleyin.
/////////////////////////////////////////////////
Option Explicit

Private Sub Command1_Click()
Dim dosya 'değişkenimiz
dosya = "\belgem.txt" 'oluşturulacak belgemiz
Open dosya For Append As #1 'burada dosyamızı 'oluşturuyoruz.

'textlerin içeriklerini 'kaydediyoruz.
Write #1, Text1.Text
Write #1, Text2.Text
Write #1, Text3.Text
Write #1, Text4.Text

'burdaki "#1"in anlamı kısaca kaydımıza numara 'veriyoruz. Okurken yine bu numarayı 'kullanacağız.

Close #1 'dosyamızı kapatıyoruz.

Form2.Visible = False
End Sub

Private Sub Form_Load()
Command1.Caption = "KAYDET"
Label1.Caption = "Adı"
Label2.Caption = "Soyadı"
Label3.Caption = "TC Kimlik No"
Label4.Caption = "Sicil No"
End Sub
/////////////////////////////////////////////////

--------------------------------------------------

3. form için kodlar. Aynı şekilde 4'er adet Label , Listbox ekleyin. label1'in alına List1'i yerleştirin diğerleride aynen.

//////////////////////////////////////////////////

Option Explicit

Private Sub Form_Load()
Dim dosya 'değişkenimiz
Dim a, b, c, d
'dört ayrı textte kayıt yaptığımız için böyle bir 'değişken belirledik.
dosya = "\belgem.txt" 'yine aynı belgemiz.

Open dosya For Input As #1
' belgemizi okumak için kodumuz

Do 'döngü açaraz okuma yapıyoruz
Input #1, a, b, c, d 'değişkenleri okuyoruz
List1.AddItem a 'listboxların içlerine atıyoruz
List2.AddItem b
List3.AddItem c
List4.AddItem d
Loop While Not EOF(1) 'döngünün sonu
'dosya sonu kontrolü
Close #1 'kapatıyoruz

Label1.Caption = "Adı"
Label2.Caption = "Soyadı"
Label3.Caption = "TC Kimlik No"
Label4.Caption = "Sicil No"
End Sub

/////////////////////////////////////////////////

--------------------------------------------------

Projenizi kaydettikten sonra deneyin. Kaydettiğiniz belgeyi bulamayabilirsiniz. Kullanıcıların kaydettiğiniz verilerinize ulaşmasını istemiyorsanız. Asci kodlar yardımıyla herkarekteri klavyeden belli bir anlamı olmayan işaretlere çevirerek kayıt yaptırabilirsiniz. Fakat okuturkende tekrar eski haline dönecek şekilde olması gerekiyor. Belgeniniz uzantısınıda değiştirebilirsiniz.

Kolay gelsin...

YAZILI TARİHLERİ ALARM SİSTEMİ

YAZILI TARİHLERİ ALARM SİSTEMİ

PROJENİN AMACI GİRİLEN YAZILILARIN TARİHLERİ GELİNCE MSGBOX'LA VE SESLİ HABER VERMESİDİR. KODLARI DEĞİŞTİRİP ÇEŞİTLİ AMAÇLAR İÇİN KULLANILABİLİR. KODLARI AYRINTILI ANLATMAYA ÇALIŞACAĞIM.

İLK ÖNCE FORMA 52 TANE TEXTBOX VE 6 TANE LABEL EKLİYORUZ. 1 VE 13 ARASI TEXTLER BİR SÜTUN. (LABEL ADI: DERSİN ADI) 14 VE 26 ARASI TEXTLER BİR SÜTUN. (LABEL ADI: 1. YAZILI). 27 VE 39 ARASI TEXTLER BİR SÜTUN. (LABEL ADI: 2. YAZILI) 40 VE 52 ARASI TEXTLER BİR SÜTUN. (LABEL ADI: 3. YAZILI)

DAHA SONRA FORMA 1 TİMER KOYUYORUZ.

TİMER1'E : SİSTEMİN SAATİNİ ALMAK İÇİN FORMA TARİH VE SAAT EKLİYORUZ. İNTERVAL'İ 100 OLACAK.

Label1.Caption = Date
Label2.Caption = Time

FORMA BİR TANE DATABASE EKLİYORUZ. YENİ DAT. DOSYASI EKLEYEREK NEW TABLE İLE YENİ TABLO EKLİYORUZ. TABLE ADI alarm OLACAK. VE ADD FİLEDE TIKLAYARAK AD GİRECEĞİZ. NAME YAZAN YERE TEKER TEKER: y1, y2, y3...y12, y13 yd1, yd2, yd3, yd4... yd37, yd38, yd39 YAZIYORUZ. YADIKTAN SONRA OK VE CLOSE SEÇİP GERİ ÇIKIYORUZ. BUİLD THE TABLE'YE TIKLAYARAK YENİ TABLO EKLEMİŞ OLUYORUZ.

DATANIN DATABASENAME SEÇENEĞİNİ EKLEMİŞ OLDUĞUMUZ DAT. DOSYASININ YERİNİ BULARAK SEÇİYORUZ. RECORDSOURCE YERİNİDE alarm SEÇİYORUZ.

DAHA SONRA FORMA GELİP EKLEMİŞ OLDUĞUMUZ 4 SÜTUN HALİNDEKİ TEXTLERİN HEPSİNİ SEÇİP DATASOURCE'SİNİ DATA1 SEÇİYORUZ. SEÇTİKTEN SONRA TEXT 1'DEN BAŞLAYIP ( YANİ İLK SÜTUNUN) TEXTLERİN DATAFİELD LARINI SIRA İLE y1, y2... y12, y13 SEÇİYORUZ. DİĞER TEXTLERİN DATAFİELD LARINIDA SIRASI İLE yd1, yd2...yd38, yd39 seçiyoruz.

FORMA 1 TANE DAHA DATA EKLİYORUZ. VE BU DATANINDA DATABASENAME VE RECORDSOURCE DATA1'İN AYNI DAT. DOSYASINI SEÇİYORUZ.

FORMA 1 TANE WİNDOWSMEDİAPLAYER EKLİYORUZ. BEN BUGÜN YAZILIN VAR DİYE BİR SES KAYDETMİŞTİM. BUNU SİZ ARTIK BAŞKA SES DOSYASI SEÇİN. SADECE " C:\Program Files/ismail/yazili.wma " ŞU BÖLÜMÜ DEĞİŞTİRMENİZ YETERLİ OLACAK.

VE FORMA 1 TANE DAHA TİMER EKLİYORUZ. İNTERVAL'İ 3000 OLACAK. VE İÇİNE:

Kod:

Private Sub Timer2_Timer()
If Data3.Recordset![yd1] = Label1.Caption Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y1] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd14] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y1] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd27] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y1] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd2] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y2] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd15] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y2] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd28] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y2] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd3] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y3] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd16] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y3] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd29] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y3] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd4] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y4] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd17] Then
MsgBox ("Bugün " & Data3.Recordset![Y4] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd30] Then
MsgBox ("Bugün " & Data3.Recordset![Y4] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd5] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y5] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd18] Then
MsgBox ("Bugün " & Data3.Recordset![Y5] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd31] Then
MsgBox ("Bugün " & Data3.Recordset![Y5] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd6] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y6] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd19] Then
MsgBox ("Bugün " & Data3.Recordset![Y6] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd32] Then
MsgBox ("Bugün " & Data3.Recordset![Y6] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd7] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y7] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd20] Then
MsgBox ("Bugün " & Data3.Recordset![Y7] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd33] Then
MsgBox ("Bugün " & Data3.Recordset![Y7] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd8] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y8] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd21] Then
MsgBox ("Bugün " & Data3.Recordset![Y8] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd34] Then
MsgBox ("Bugün " & Data3.Recordset![Y8] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd9] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y9] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd22] Then
MsgBox ("Bugün " & Data3.Recordset![Y9] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd35] Then
MsgBox ("Bugün " & Data3.Recordset![Y9] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd10] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y10] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd23] Then
MsgBox ("Bugün " & Data3.Recordset![Y10] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd36] Then
MsgBox ("Bugün " & Data3.Recordset![Y10] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd11] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y11] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd24] Then
MsgBox ("Bugün " & Data3.Recordset![Y11] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd37] Then
MsgBox ("Bugün " & Data3.Recordset![Y11] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd12] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y12] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd25] Then
MsgBox ("Bugün " & Data3.Recordset![Y12] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd38] Then
MsgBox ("Bugün " & Data3.Recordset![Y12] & " yazılın var")
Timer2.Enabled = False
End If
If Label1.Caption = Data3.Recordset![yd13] Then
WindowsMediaPlayer1.URL = "C:\Program Files/ismail/yazili.wma"
MsgBox ("Bugün " & Data3.Recordset![Y13] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd26] Then
MsgBox ("Bugün " & Data3.Recordset![Y13] & " yazılın var")
Timer2.Enabled = False
ElseIf Label1.Caption = Data3.Recordset![yd39] Then
MsgBox ("Bugün " & Data3.Recordset![Y13] & " yazılın var")
Timer2.Enabled = False
End If
End Sub


FORMA BİR TANE COMMANDBUTON EKLEYİP İÇİNE

Private Sub Command1_Click()
Data1.Recordset.AddNew
End
End Sub

YAZIYORUZ. VERİLERİ KAYDEDİP ÇIKMASI İÇN. ÖNERİ: YAZILI TARİHLERİNİ 1-2 GÜN ÖNCEKİ TARİHİ GİRİNİZ. ÖNCEDEN HABER VEREBİLMESİ İÇİN. KOLAY GELSİN...

Exel Macro Kodu

Kod:

[font=Courier New]Sub Okek()


----Örneğin Okek'ini  bulacağımız sayıları excel hücrelerimizde a sütununda  alt alta yazalım. Arada  boş bırakılan hücre olmasın.  A sütununda yazdığımız rakamlardan başka  bir şey yazılı olmasın ---





----Değişkenleri tanımlayalım.---





Dim uzunluk, mak, mak1, say, bul, deger


Dim dizi()





---- dizi() adlı dizi değişkeni tanımladık,şimdilik dizi boyutunu boş bıraktık , dizi boyutunu a sütunundaki dolu hücre sayısını öğrenince redim komutuyla belirleyeceğiz---





Dim yön As Boolean


bul = 1





--- A sütununda 65000'inci satıra kadar olan hücrelerden  yukarıdan aşağıya inildiğinde en aşağıdaki son dolu hücrenin  kaçıncı satırda olduğunu bulalım.---





uzunluk = [a65000].End(3).Row





---eğer rakamların yazılacağı A sütununda 2 den az sayıda hücrede rakam varsa obeb veya okek hesaplamaya gerek kalmaz. Durum öyle ise exit sub yap yani bu programcığı burada kapat, çalışmasını durdur yani ---





If uzunluk < 2 Then Exit Sub





--- Dizi() adlı dizi değişkeninin boyutunu A sütunundaki rakam adedi kadar yapıyoruz.---





ReDim dizi(uzunluk)





--- A sütunundaki en büyük rakamı buluyoruz. Okek bulmak için bize lazım olacak---





mak = WorksheetFunction.Max(Range("A1:A" & uzunluk))


mak1 = mak


ilk:





--- Aşağıda, önce kendimiz ilk 1. yöntemimizi uygulayıp yukarıda bulduğumuz bu mak değerini mak1 değişkenine atıyoruz. Ve A sütunundaki tüm değerler, mak1 değişkenine bölüyoruz. Hepsi kalansız bölünebiliyorsa okek değerini bulmuş olduk. (Okek=mak1). Eğer tek bir tanesi bile mak1 değerine tam kalansız bölünemiyorsa hemen döngüden çıkıp mak1 değerine yukarıdaki mak değerini ekleyip (yani mak1=mak1+mak) işlemi tekrar yapıyoruz. Yani yeni mak1 değerini a sütunundaki tüm değerlere bölüyoruz. Hepsi kalansız bölünüyorsa okek yeni mak1 değeridir. Bölünmeyen değer varsa yine döngüden çıkıyoruz ve mak1 değerine mak değerini ekleyip döngüye girip işlemi tekrar yapıyoruz. 751 kere döngüye girilip okek değeri bulunamazsa  ( yani 751 dafa mak1=mak1+mak yapıldığı halde hala okek değerine ulaşılamadı ise) okek bulmak için (ileri:) alanına atlayıp  2. yönteme geçiyoruz.---





For i = 1 To uzunluk


    If mak1 Mod Cells(i, 1) > 0 Then


      mak1 = mak1 + mak


      say = say + 1


      If say > 751 Then


        GoTo ileri


      End If


      DoEvents


      GoTo ilk


      End If


     


Next


----okek bulmak için kullandığımız 2. yöntem buradan başlıyor---





ileri:


A sütunundaki değerler dizi() değişkenine alınıyor, (üzerlerinde daha rahat işlem yapabilmek için)---





For x = 1 To uzunluk


dizi(x) = Cells(x, 1)


Next





---aşağıda matematikte kullanılan birden fazla sayının okek'ini alma işlemi bilgisayara kodlarla yaptırılıyor, tüm rakamlar 2'ye bölünüyor, tekrar 2'ye bölünebilen varsa 2'ye bölünüyor. Sonra 3'e bölünüyor, 4'e bölünüyor, vb.. Taki listedeki tüm rakamlar bölüne bölüne asal sayı olana kadar. Sonra tüm bölen rakamlar birbiri ile çarpılarak okek bulunuyor. Aynen matematikte birden fazla sayının okekini alma işlemi yani---





For v = 2 To mak


yön = False


For y = 1 To uzunluk


If dizi(y) Mod v = 0 Then


yön = True


dizi(y) = dizi(y) / v


End If


Next


If yön = True Then


bul = bul * v


For i = 1 To uzunluk


    For j = 1 To uzunluk





      If dizi(i) > dizi(j) Then


      deger = dizi(i)


      dizi(i) = dizi(j)


      dizi(j) = deger


      End If


      Next


      Next


      mak = dizi(1)


    v = 1


    End If


    Next





--- şimdi emeğimizin karşılığını alma zamanı, bulduğumuz sonuçları hücrelere yazdırarak


veya msgbox ile bildirerek, gereken yerlerde kullanırız.---





    Range("A1:A" & uzunluk).Select 


    Cells(1, 2) = "Okek ="


    Cells(1, 2).Font.Bold = True


    Cells(1, 3) = bul


  MsgBox "OKEK = " & bul


End Sub

Sub Okek()


----Örneğin Okek'ini  bulacağımız sayıları excel hücrelerimizde a sütununda  alt alta yazalım. Arada  boş bırakılan hücre olmasın.  A sütununda yazdığımız rakamlardan başka  bir şey yazılı olmasın ---





----Değişkenleri tanımlayalım.---





Dim uzunluk, mak, mak1, say, bul, deger


Dim dizi()





---- dizi() adlı dizi değişkeni tanımladık,şimdilik dizi boyutunu boş bıraktık , dizi boyutunu a sütunundaki dolu hücre sayısını öğrenince redim komutuyla belirleyeceğiz---





Dim yön As Boolean


bul = 1





--- A sütununda 65000'inci satıra kadar olan hücrelerden  yukarıdan aşağıya inildiğinde en aşağıdaki son dolu hücrenin  kaçıncı satırda olduğunu bulalım.---





uzunluk = [a65000].End(3).Row





---eğer rakamların yazılacağı A sütununda 2 den az sayıda hücrede rakam varsa obeb veya okek hesaplamaya gerek kalmaz. Durum öyle ise exit sub yap yani bu programcığı burada kapat, çalışmasını durdur yani ---





If uzunluk < 2 Then Exit Sub





--- Dizi() adlı dizi değişkeninin boyutunu A sütunundaki rakam adedi kadar yapıyoruz.---





ReDim dizi(uzunluk)





--- A sütunundaki en büyük rakamı buluyoruz. Okek bulmak için bize lazım olacak---





mak = WorksheetFunction.Max(Range("A1:A" & uzunluk))


mak1 = mak


ilk:





--- Aşağıda, önce kendimiz ilk 1. yöntemimizi uygulayıp yukarıda bulduğumuz bu mak değerini mak1 değişkenine atıyoruz. Ve A sütunundaki tüm değerler, mak1 değişkenine bölüyoruz. Hepsi kalansız bölünebiliyorsa okek değerini bulmuş olduk. (Okek=mak1). Eğer tek bir tanesi bile mak1 değerine tam kalansız bölünemiyorsa hemen döngüden çıkıp mak1 değerine yukarıdaki mak değerini ekleyip (yani mak1=mak1+mak) işlemi tekrar yapıyoruz. Yani yeni mak1 değerini a sütunundaki tüm değerlere bölüyoruz. Hepsi kalansız bölünüyorsa okek yeni mak1 değeridir. Bölünmeyen değer varsa yine döngüden çıkıyoruz ve mak1 değerine mak değerini ekleyip döngüye girip işlemi tekrar yapıyoruz. 751 kere döngüye girilip okek değeri bulunamazsa  ( yani 751 dafa mak1=mak1+mak yapıldığı halde hala okek değerine ulaşılamadı ise) okek bulmak için (ileri:) alanına atlayıp  2. yönteme geçiyoruz.---





For i = 1 To uzunluk


    If mak1 Mod Cells(i, 1) > 0 Then


      mak1 = mak1 + mak


      say = say + 1


      If say > 751 Then


        GoTo ileri


      End If


      DoEvents


      GoTo ilk


      End If


     


Next


----okek bulmak için kullandığımız 2. yöntem buradan başlıyor---





ileri:


A sütunundaki değerler dizi() değişkenine alınıyor, (üzerlerinde daha rahat işlem yapabilmek için)---





For x = 1 To uzunluk


dizi(x) = Cells(x, 1)


Next





---aşağıda matematikte kullanılan birden fazla sayının okek'ini alma işlemi bilgisayara kodlarla yaptırılıyor, tüm rakamlar 2'ye bölünüyor, tekrar 2'ye bölünebilen varsa 2'ye bölünüyor. Sonra 3'e bölünüyor, 4'e bölünüyor, vb.. Taki listedeki tüm rakamlar bölüne bölüne asal sayı olana kadar. Sonra tüm bölen rakamlar birbiri ile çarpılarak okek bulunuyor. Aynen matematikte birden fazla sayının okekini alma işlemi yani---





For v = 2 To mak


yön = False


For y = 1 To uzunluk


If dizi(y) Mod v = 0 Then


yön = True


dizi(y) = dizi(y) / v


End If


Next


If yön = True Then


bul = bul * v


For i = 1 To uzunluk


    For j = 1 To uzunluk





      If dizi(i) > dizi(j) Then


      deger = dizi(i)


      dizi(i) = dizi(j)


      dizi(j) = deger


      End If


      Next


      Next


      mak = dizi(1)


    v = 1


    End If


    Next





--- şimdi emeğimizin karşılığını alma zamanı, bulduğumuz sonuçları hücrelere yazdırarak


veya msgbox ile bildirerek, gereken yerlerde kullanırız.---





    Range("A1:A" & uzunluk).Select 


    Cells(1, 2) = "Okek ="


    Cells(1, 2).Font.Bold = True


    Cells(1, 3) = bul


  MsgBox "OKEK = " & bul


End Sub
[/font]

IP Adresi Bulmak

Kod:

'Aşağıdakileri modüle kopyalayın

Public Const MAX_WSADescription = 256

Public Const MAX_WSASYSStatus = 128

Public Const ERROR_SUCCESS As Long = 0

Public Const WS_VERSION_REQD As Long = &H101

Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&

Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&

Public Const MIN_SOCKETS_REQD As Long = 1

Public Const SOCKET_ERROR As Long = -1

Public Type HOSTENT

hName As Long

hAliases As Long

hAddrType As Integer

hLen As Integer

hAddrList As Long

End Type

Public Type WSADATA

wVersion As Integer

wHighVersion As Integer

szDescription(0 To MAX_WSADescription) As Byte

szSystemStatus(0 To MAX_WSASYSStatus) As Byte

wMaxSockets As Integer

wMaxUDPDG As Integer

dwVendorInfo As Long

End Type

Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long

Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long

Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)



Public Function GetIPAddress() As String

Dim sHostName As String * 256

Dim lpHost As Long

Dim HOST As HOSTENT

Dim dwIPAddr As Long

Dim tmpIPAddr() As Byte

Dim i As Integer

Dim sIPAddr As String

If Not SocketsInitialize() Then

GetIPAddress = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then

GetIPAddress = ""

MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."

SocketsCleanup

Exit Function

End If

sHostName = Trim$(sHostName)

lpHost = gethostbyname(sHostName)

If lpHost = 0 Then

GetIPAddress = ""

MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name."

SocketsCleanup

Exit Function

End If

CopyMemory HOST, lpHost, Len(HOST)

CopyMemory dwIPAddr, HOST.hAddrList, 4

ReDim tmpIPAddr(1 To HOST.hLen)

CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen

For i = 1 To HOST.hLen

sIPAddr = sIPAddr & tmpIPAddr(i) & "."

Next

GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)

SocketsCleanup

End Function



Public Function GetIPHostName() As String

Dim sHostName As String * 256

If Not SocketsInitialize() Then

GetIPHostName = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then

GetIPHostName = ""

MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."

SocketsCleanup

Exit Function

End If

GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)

SocketsCleanup

End Function





Public Function HiByte(ByVal wParam As Integer)

HiByte = wParam \ &H100 And &HFF&

End Function



Public Function LoByte(ByVal wParam As Integer)

LoByte = wParam And &HFF&

End Function



Public Sub SocketsCleanup()

If WSACleanup() <> ERROR_SUCCESS Then

MsgBox "Socket error occurred in Cleanup."

End If

End Sub



Public Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA

Dim sLoByte As String

Dim sHiByte As String

If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then

MsgBox "The 32-bit Windows Socket is not responding."

SocketsInitialize = False

Exit Function

End If

If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then

MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."

SocketsInitialize = False

Exit Function

End If

If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then

"BUNLARI MODÜLE YAZ"
sHiByte = CStr(HiByte(WSAD.wVersion))

sLoByte = CStr(LoByte(WSAD.wVersion))

MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."

SocketsInitialize = False

Exit Function

End If

SocketsInitialize = True

End Function
"BUNLARI FORMA YAZ"

Private Sub Form_Load()

MsgBox "IP Host Name: " & GetIPHostName()

MsgBox "IP Address: " & GetIPAddress()

End Sub
Ip Adresi Bulmak Vb ile

[size=9]'Aşağıdakileri modüle kopyalayın

Public Const MAX_WSADescription = 256

Public Const MAX_WSASYSStatus = 128

Public Const ERROR_SUCCESS As Long = 0

Public Const WS_VERSION_REQD As Long = &H101

Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&

Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&

Public Const MIN_SOCKETS_REQD As Long = 1

Public Const SOCKET_ERROR As Long = -1

Public Type HOSTENT

hName As Long

hAliases As Long

hAddrType As Integer

hLen As Integer

hAddrList As Long

End Type

Public Type WSADATA

wVersion As Integer

wHighVersion As Integer

szDescription(0 To MAX_WSADescription) As Byte

szSystemStatus(0 To MAX_WSASYSStatus) As Byte

wMaxSockets As Integer

wMaxUDPDG As Integer

dwVendorInfo As Long

End Type

Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long

Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long

Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)



Public Function GetIPAddress() As String

Dim sHostName As String * 256

Dim lpHost As Long

Dim HOST As HOSTENT

Dim dwIPAddr As Long

Dim tmpIPAddr() As Byte

Dim i As Integer

Dim sIPAddr As String

If Not SocketsInitialize() Then

GetIPAddress = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then

GetIPAddress = ""

MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."

SocketsCleanup

Exit Function

End If

sHostName = Trim$(sHostName)

lpHost = gethostbyname(sHostName)

If lpHost = 0 Then

GetIPAddress = ""

MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name."

SocketsCleanup

Exit Function

End If

CopyMemory HOST, lpHost, Len(HOST)

CopyMemory dwIPAddr, HOST.hAddrList, 4

ReDim tmpIPAddr(1 To HOST.hLen)

CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen

For i = 1 To HOST.hLen

sIPAddr = sIPAddr & tmpIPAddr(i) & "."

Next

GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)

SocketsCleanup

End Function



Public Function GetIPHostName() As String

Dim sHostName As String * 256

If Not SocketsInitialize() Then

GetIPHostName = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then

GetIPHostName = ""

MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."

SocketsCleanup

Exit Function

End If

GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)

SocketsCleanup

End Function





Public Function HiByte(ByVal wParam As Integer)

HiByte = wParam \ &H100 And &HFF&

End Function



Public Function LoByte(ByVal wParam As Integer)

LoByte = wParam And &HFF&

End Function



Public Sub SocketsCleanup()

If WSACleanup() <> ERROR_SUCCESS Then

MsgBox "Socket error occurred in Cleanup."

End If

End Sub



Public Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA

Dim sLoByte As String

Dim sHiByte As String

If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then

MsgBox "The 32-bit Windows Socket is not responding."

SocketsInitialize = False

Exit Function

End If

If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then

MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."

SocketsInitialize = False

Exit Function

End If

If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then

"BUNLARI MODÜLE YAZ"
sHiByte = CStr(HiByte(WSAD.wVersion))

sLoByte = CStr(LoByte(WSAD.wVersion))

MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."

SocketsInitialize = False

Exit Function

End If

SocketsInitialize = True

End Function
"BUNLARI FORMA YAZ"

Private Sub Form_Load()

MsgBox "IP Host Name: " & GetIPHostName()

MsgBox "IP Address: " & GetIPAddress()

End Sub[/size]