Bi kaç Visual Basic kodu daha :)

MaXXSoFT

MaXXSoFT

New member
Katılım
28 Haz 2005
Mesajlar
1,569
Reaction score
0
Puanları
0
Yaş
36
Konum
Ankara-Aydın
Belirli Türdeki Dosyaların Başına Tarih Ekliyor

Private Sub Command1_Click()
'Aşağıdaki Kod Explorerda dosya özellikleri kısmında bulunan Tür bölümü içinden yazılan
'"JPEG Resmi" yazan dosyaların başına tarih ekliyor
Dim Fsys As New FileSystemObject
Dim ListArgs
Dim ObjFolder, ObjFile
Dim szDateCreated, szYear, szMonth, szDay


If Fsys.FolderExists("C:\Yedek\ArşivBackup\Resim\Norm") Then
Set ObjFolder = Fsys.GetFolder("C:\Yedek\ArşivBackup\Resim\Norm")
For Each ObjFile In ObjFolder.Files
If ObjFile.Type = "JPEG Resmi" Then
szDateCreated = ObjFile.DateCreated
szYear = Year(szDateCreated)
szMonth = Month(szDateCreated)
szDay = Day(szDateCreated)
If szMonth < 10 Then
szMonth = "0" & szMonth
End If

If szDay < 10 Then
szDay = "0" & szDay
End If

szDateCreated = szYear & "-" & szMonth & "-" & szDay

If szDateCreated <> Left(ObjFile.Name, 10) Then
ObjFile.Name = szDateCreated & " " & ObjFile.Name
End If

End If
Next
Else
MsgBox "Seçilen Klasör Bulunamadı!"
End If
 
Kelimenin ilk harfini büyük diğerlerini küçük yaz (Türkçe isim yazma kuralı)

Public Function LCaseFirst(KeyAsc As Integer, txt As String) As Integer
Dim tX
tX = KeyAsc
If KeyAsc <> 32 And Len(Trim(txt)) = 0 Then
bh = True
End If
If Not bh Then
Select Case tX
Case Asc("I"), Asc("ı"): tX = Asc("ı"): bh = False
Case Asc("İ"), Asc("i"): tX = Asc("i"): bh = False
Case Asc("Ö"), Asc("ö"): tX = Asc("ö"): bh = False
Case Asc("Ü"), Asc("ü"): tX = Asc("ü"): bh = False
Case Asc("Ğ"), Asc("ğ"): tX = Asc("ğ"): bh = False
Case Asc("Ç"), Asc("ç"): tX = Asc("ç"): bh = False
Case Asc("Ş"), Asc("ş"): tX = Asc("ş"): bh = False
Case 32: bh = True: tX = 32
Case Else
tX = Asc(LCase(Chr(tX))): bh = False
End Select
Else
Select Case tX
Case Asc("I"), Asc("ı"): tX = Asc("I"): bh = False
Case Asc("İ"), Asc("i"): tX = Asc("İ"): bh = False
Case Asc("Ö"), Asc("ö"): tX = Asc("Ö"): bh = False
Case Asc("Ü"), Asc("ü"): tX = Asc("Ü"): bh = False
Case Asc("Ğ"), Asc("ğ"): tX = Asc("Ğ"): bh = False
Case Asc("Ç"), Asc("ç"): tX = Asc("Ç"): bh = False
Case Asc("Ş"), Asc("ş"): tX = Asc("Ş"): bh = False
Case 32: bh = True: tX = 32
Case Else
tX = Asc(UCase(Chr(tX))): bh = False
End Select
End If
LCaseFirst = tX

End Function


kelimenin tüm harflerini büyük yaz (Türkçe soyiadı yazma kuralı)

Public Function LCaseAll(KeyAsc As Integer) As Integer
Dim tX
tX = KeyAsc
Select Case tX
Case Asc("I"), Asc("ı"): tX = Asc("I")
Case Asc("İ"), Asc("i"): tX = Asc("İ")
Case Asc("Ö"), Asc("ö"): tX = Asc("Ö")
Case Asc("Ü"), Asc("ü"): tX = Asc("Ü")
Case Asc("Ğ"), Asc("ğ"): tX = Asc("Ğ")
Case Asc("Ç"), Asc("ç"): tX = Asc("Ç")
Case Asc("Ş"), Asc("ş"): tX = Asc("Ş")
Case Else
tX = Asc(UCase(Chr(tX)))
End Select
LCaseAll = tX
End Function





Textbox nesnesinin keypress olayı (ENTER tuşu tab tuşuna eşitleniyor)

xgiriş(0) Soyadı
xgiriş(1) Adı

Private Sub xGiriş_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0: SendKeys "{TAB}", True
End If
Select Case Index
Case 0: KeyAscii = LCaseAll(KeyAscii)
Case 1: KeyAscii = LCaseFirst(KeyAscii, xGiriş(1).Text)
End Select
End Sub
 
Kronometre

Private Sub Command1_Click()
Timer1.Enabled = True
End Sub

Private Sub Command2_Click()
Timer1.Enabled = False
End Sub

Private Sub Command3_Click()
saniye = 0
saat = 0
dakika = 0
Label1.Caption = "00"
Label2.Caption = "00"
Label3.Caption = "00"
End Sub

Private Sub Form_Load()
Label1.Caption = "00"
Label2.Caption = "00"
Label3.Caption = "00"
Timer1.Interval = 1000
Timer1.Enabled = False
End Sub

Private Sub Timer1_Timer()
saniye = saniye + 1
If saniye = 60 Then
saniye = 0
dakika = dakika + 1
If dakika = 60 Then
dakika = 0
saat = saat + 1
If saat = 24 Then
saat = 0
End If
End If
End If
If saat < 10 Then
Label1.Caption = "0" & Str(saat)
Else
Label1.Caption = saat
End If
If dakika < 10 Then
Label2.Caption = "0" & Str(dakika)
Else
Label2.Caption = dakika
End If
If saniye < 10 Then
Label3.Caption = "0" & Str(saniye)
Else
Label3.Caption = saniye
End If
End Sub
 
Güzel bir alarmlı saat proggramı yalnız mp3 play.ocx dosyasına ihtiyacınız olacak

MP3 çalan bir program yapmadan önce mp3play.ocx dosyasını internetden search ederek bulmanız gerekiyor. Bundan sonra işiniz 'kolay.

' Edit box'ın read only (dışarıdan herhangi bir şey girilemesin) olmasını sağlayın ve STOP tuşunun "Enabled" özelliğinide '"False" yapın. Tüm tuşların isimlerine göre fonksiyonlar aşağıdadır. Bu arada formda "SAAT" yazan yerin altında bir label 'var, label'ın background rengini siyah yapın.

' Aşağıdaki tüm kodu kopyalayın ve General Declerations kısmından itibaren paste edin. Uygun tuşlara, uygun fonksiyonlarıda 'bağlayın. Böylece kod çalıştırılabilir hale gelecektir.


Option Explicit
Dim AlarmTime
Dim Sound As String
Dim got As Long
Const conMinimized = 1
Dim char As String

Private Sub alarm_Click()
AlarmTime = InputBox("Saat kaçta alarm çalsın?", "Alaryum", AlarmTime)
If AlarmTime = "" Then Exit Sub
If Not IsDate(AlarmTime) Then
MsgBox "Girilen saat geçerli değil"
Else
AlarmTime = CDate(AlarmTime)
Text1.Text = AlarmTime
End If
End Sub

Private Sub cikis_Click()
End
End Sub

Private Sub sarkisec_Click()
CommonDialog1.ShowOpen
Sound = CommonDialog1.FileName
Text2.Text = CommonDialog1.FileName
End Sub
Private Sub stopsong_Click()
Mp3Play1.stop
End Sub

Private Sub Form_Resize()
If WindowState = conMinimized Then
SetCaptionTime
Else
Caption = "Alaryum"
End If
End Sub

Private Sub SetCaptionTime()
Caption = Format(Time, "Medium Time")
End Sub

Private Sub Timer1_Timer()
lblTime.Caption = Time
If Time = AlarmTime Then
got = Mp3Play1.Open(Sound, "")
Mp3Play1.Play
stopsong.enabled = True
stopsong.Default = True
End If
If WindowState = conMinimized Then
If Minute(CDate(Caption)) <> Minute(Time) Then SetCaptionTime
Else
lblTime.Caption = Time
End If
End Sub



' Önce Alarm tuşuna basarak bir alarm zamanı girmeniz gerekir. Bunuda 00:00:00 formatında girmelisiniz. Daha sonrada 'çalacak MP3'ü seçip zamanın gelmesini bekliyeceksiniz. MP3 çalmaya başladıktan sonra STOP tuşu enable olacaktır. Bundan 'sonra stop tuşuna basmak için mouse yerine enter tuşunu kullanmak daha pratik olacağından default seçeneğinide true 'yapıyoruz. Ayrıca runtime (çalışma) esnasında formu minimize ederseniz start barda formun ismi yerine zaman belirecektir.
 
Ağ bağlantısındaki bir bilgisayara istediğiniz kadar mesaj yollaya bilirsiniz hemde binlerce.
yapmanız gereken ms-dos'a girip "nbtstat - n" yazmak (tırnakları yazmıyacağız).Burada bilgisayarın adını ve IP numarasını alırsınız. Ama size lazım olan bilgisayarın ismidir.
Sizin için gerekli olan 3 tane textbox ve bir tane button.


text1 kullanıcının adını yazacağınız textbox'dır
'text2 kullanıcıya göndereceğiniz mesajdır
'text3 kaç tane göndermek istediğiniz textbox'dır
Private Sub command1_click()

dim mesaj as string
dim sayi as double
dim i

mesaj = text2
sayi = val(text3)

for i = 0 to sayi

shell net send & "text1.text" & mesaj

next

end sub
 
programınızın kurulurken registerye kayıt olmasını istiyosanız en sonda program adını ve pathini girin yeter

Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type

Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte

Const DisplayErrorMsg = False

Private Sub Form_Load()
Call SetStringValue("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "program_name_here", "C:\program name title.exe")
end sub
 
Sayıyı yazıya çeviren Fonksiyon!

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

Function Yaziyla$(sayi)

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

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

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

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

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

If s$ = "" Then s$ = "Sıfır"
If pozitif = 0 Then s$ = "Eksi" + s$
Yaziyla$ = s$
GoTo tamam
hata: Yaziyla$ = "Hata"
tamam:
End Function
 
Formatlanmış CD-RW lere dosya kopyalayıp yedekleme yapabilirsiniz

Formatlanmış yeniden yazılabilir cd leri bir büyük bir disketmiş gibi kullanabiliceğimizden dolayı
VB de kullanılan dosya kopyalama ve silme komutları bu diskler içinde kullanılabilir.
Formatlama işlemini CD Writer ınızla gelen programlara(In CD, Easy Cd Creator,...vb gibi) 1 kez yaptırdıktan sonra artık bu diskler disketten farksızdır.
Aşağıdaki kod örneğinde ilk önce bilgisayardaki CD sürücü harfi tespit ediliyor daha sonra Cd deki boş alan bulunuyor ve c: deki Deneme.mdb isimli bir dosya CD ye kopyalanıyor.





Rem ------Kullanıcıyı yedekleme yapmak isteyip istemediği konusunda uyar ve sonucu DoIt Rem ------değişkenine ata------
MsgText = Date & " tarihli yedekleme alınacak. Devam Edilsin mi?"
MsgText = MsgText & vbCrlf & "Cd ye yedekleme yapabilmeniz için yeniden yazılabilir CD nizin takılı ve önceden formatlanmış olması gerekmektedir."
DoIt = Msgbox(MsgText,vbYesNo,"Uyarı!")
Rem ------Eğer kullanıcını cevabı evet ise aşağıdaki kodu işlet------
if DoIt = vbYes then
Rem ------filesys isimli dosya sistemi nesnesi oluştur------
Set filesys = CreateObject("Scripting.FileSystemObject")
Rem ------drvcoll değişkenine filesys nesnesindeki sürücüleri ata------
Set drvcoll = filesys.Drives
Rem ------Bilgisayardaki Cd sürücünün harfini ve Cd deki boş alanı bularak DriveLetter Rem -----CdFreeSpace değişkenlerine ata------
For Each drv in drvcoll
if drv.DriveType = 4 then 'burdaki 4 CD romun kodudur. Örneğin 1 Disket sürücüdür.
DriveLetter = drv.DriveLetter
CdFreeSpace = drv.availablespace
End if
Next
Rem ------Cd sürücüsü yoksa uyar------
if DriveLetter="" then
MsgBox "CD Sürücü bulunamadı."
Else
Rem ------Yedeklenecek dosyaların bulunduğu klasörü SourceFolder değişkenine-
Rem ------Yedekleme yapılacak klasörü BackupFolder değişkenine ata-----
SourceFolder = "c:\"
BackupFolder = DriveLetter & ":\" & Date & "\"
Rem ------Yedeklenecek dosyaların boyutunu bul ve FileSize değişkenine ata-----
Set fileObject = filesys.GetFile(SourceFolder & "\TMODB.db")
FileSize = fileObject.Size
Set fileObject = filesys.GetFile(SourceFolder & "\TMODB.log")
FileSize = fileObject.Size + FileSize
Rem ------Eğer Cd de yeterli alan yok ise kullanıcıyı uyar------
if CdFreeSpace < FileSize then
MsgText = " Cd de yeterli boş alan yok!"
MsgText = MsgText & vbCrlf & "Boş Alan : " & CdFreeSpace & " Byte"
MsgText = MsgText & vbCrlf & "Gerekli Alan : " & FileSize & " Byte"
MsgBox MsgText
Else
Rem ------Eğer Yedekleme klasörü mevcut ise uyar------
if filesys.FolderExists(BackupFolder) then
MsgText = "CD de " & Date & " tarihli yedekleme dosyası var."
MsgText = MsgText & vbCrlf & "Üzerine yazılsınmı?"
DoIt = Msgbox(MsgText,vbYesNo,"Uyarı!")
Rem ------Eğer cevap evet ise dosyaları üzerine yaz------
if DoIt = vbYes Then
filesys.CopyFile SourceFolder & "Deneme.mdb", BackupFolder , True
Rem üst satırdaki True eğer dosya mevcut ise üstüne yazılacağını belirtiyor
MsgBox "Yedekleme tamamlandı"
End if
Else
Rem ------Hedef klasörü oluştur ve dosyaları Cd ye yedekle------
Set NewFolder = filesys.CreateFolder(BackupFolder)
filesys.CopyFile SourceFolder & "Deneme.mdb", BackupFolder
MsgBox "Yedekleme tamamlandı"
End if
End if
End if
End if
set filesys = nothing
 
çok sağol kardeş ya eline sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst