WaMPiR_CaDı

Visual Basic Ile Kisayol yapmak !
Visual basic ile kisayol yapmanin bir çok yolu vardir. Bunlardan en basiti bu yazi ile anlatilmaktadir. DDE teknolojisi kullanilan bu yöntemde bilmemiz gerekenler;
1- Baslat menüsünde programlar klasörünün yerinin ögrenilmesi,
2- Masaüstü klasörü yerinin ögrenilmesi,
3- DDE kullanarak baska bir programla iliski kurulmasi,
4- Açik bir baska pencerenin kapatilmasi,
Hemen uygulamaya geçelim;
a) Yeni bir proje baslatin
b) 1 ve 2 inci maddelerin uygulanmasi için sistem kayit dosyasindan okuma yapmamiz gerekiyor. Bu nedenle projenize yeni bir modül ekleyip bu module asagidaki kodlari yazin;
Option Explicit
Public Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegOpenKey Lib _
"advapi32.dll" Alias "RegOpenKeyA" _
(ByVal Hkey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Private 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
Const ERROR_SUCCESS = 0&
Const REG_SZ = 1
Public Function GetString(Hkey As Long, _
strPath As String, _
strValue As String)
Dim keyhand As Long
Dim datatype As Long
Dim lResult As Long
Dim strBuf As String
Dim lDataBufSize As Long
Dim intZeroPos As Integer
Dim R
Dim lValueType As Long
R = RegOpenKey(Hkey, strPath, keyhand)
lResult = RegQueryValueEx(keyhand, _
strValue, 0&, lValueType, _
ByVal 0&, lDataBufSize)
If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(keyhand, _
strValue, 0&, 0&, ByVal strBuf, _
lDataBufSize)
If lResult = ERROR_SUCCESS Then
intZeroPos = InStr(strBuf, Chr$(0))
If intZeroPos > 0 Then
GetString = Left$(strBuf, _
intZeroPos - 1)
Else
GetString = strBuf
End If
End If
End If
End Function
c) 3 üncü maddenin uygulanmasi için projenize yeni bir modül ekleyip bu module asagidaki kodlari yazin;
Option Explicit
Sub KisayolYap(Nesne As Label, _
ByVal Grupismi As String, ByVal Programismi As String, _
ByVal TaniticiBilgi As String, ByVal NeEkle As Integer)
Const Virgül$ = ","
Const Düzelt$ = ", 1)]"
Const Aktif$ = ", 5)]"
Const Son$ = ")]"
Const Göster$ = "[ShowGroup("
Const GrupYarat$ = "[CreateGroup("
Const Yerlestir$ = "[ReplaceItem("
Const Ekle$ = "[AddItem("
Programismi = Chr(34) + Programismi + Chr(34)
Grupismi = Chr(34) + Grupismi + Chr(34)
Dim Döngü As Integer
Dim DenemeDöngü As Integer
For DenemeDöngü = 1 To 20
On Error Resume Next
Nesne.l inkTopic = "PROGMAN|PROGMAN"
If Err = 0 Then
Exit For
End If
DoEvents
Next DenemeDöngü
Nesne.l inkMode = 2
For Döngü = 1 To 10
DoEvents
Next
Nesne.l inkTimeout = 100
On Error Resume Next
If Err = 0 Then
Select Case NeEkle
Case 1 ’Program ekle
#If 0 Then
Nesne.l inkExecute Göster & Grupismi & Aktif
#Else
Nesne.l inkExecute GrupYarat & Grupismi & Son
#End If
Nesne.l inkExecute Yerlestir & TaniticiBilgi & Son
Err = 0
Nesne.l inkExecute Ekle & Programismi & Virgül _
& TaniticiBilgi & String$(3, Virgül) & Son
Case 2 ’Grup ekle
Nesne.l inkExecute GrupYarat & Grupismi & Son
Nesne.l inkExecute Göster & Grupismi & Düzelt
End Select
End If
For Döngü = 1 To 10
DoEvents
Next
Nesne.l inkMode = 0
Nesne.l inkTopic = ""
Err = 0
End Sub
d) 4 inci maddenin uygulanmasi için projenize yeni bir modül ekleyip bu module asagidaki kodlari yazin;
Option Explicit
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" _
Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Sub WindowsPencereKapat(Basligi$, FHandle&)
Dim Aktif As Integer, Uz As Integer, Baslik As String
Basligi = LCase(Basligi)
Aktif = GetWindow(FHandle, 0)
While Aktif <> 0
Uz = GetWindowTextLength(Aktif)
Baslik = Space(Uz + 1)
Uz = GetWindowText(Aktif, Baslik, Uz + 1)
Baslik = LCase(Baslik)
If Baslik = Basligi + Chr(0) Then
Dim Dur As Long
Dur = PostMessage(Aktif, &H10, 0&, 0&)
Exit Sub
End If
Aktif = GetWindow(Aktif, 2)
Wend
End Sub
e) Formun üzerine 3 label, 3 textbox, 1 command button, 2 checkbox alin ve özelliklerini;
Label1.caption="Tanitici Bilgi"
Label2.caption="Grup adi"
Label3.caption="Program adi"
Text1="Deneme"
Text2="Grup Dene"
Text3="C:\Deneme.exe"
Command1.caption="Yap"
Check1.caption="Baslat menüsüne ekle"
Check2.caption="Masa üstüne ekle"
olacak sekilde properties penceresinden düzenleyin
f) Formun kodlari asagidaki gibi olsun;
Option Explicit
Sub KisaYoluYap(Grup$, Dosya$, Kisayol$)
Dim Tanitici$, KDosya$
Tanitici = Kisayol
’Baslat menüsünün yeri
KDosya = GetString(HKEY_CURRENT_USER, _
"Software\Microsoft\Windows\CurrentVersion\Exp lore r \Shell Folders", _
"Programs")
SonunaFlAshEkle KDosya
KDosya = KDosya + Grup
SonunaFlAshEkle KDosya
KDosya = KDosya + Tanitici + ".lnk"
If DosyaVar(KDosya) Then
’Ayni kisayol varsa sil
Kill KDosya
End If
DoEvents
KisayolYap Label1, Grup, "", "", 2
KisayolYap Label1, Grup, Dosya, Tanitici, 1
DoEvents
If DosyaVar(KDosya) = False Then
MsgBox ("Kisayol olusturulamadi!")
Exit Sub
End If
’Masaüstüne ekle
If Check2.Value = 1 Then
Dim Masa$
’Masaüstünün yeri
Masa = GetString(HKEY_CURRENT_USER, _
"Software\Microsoft\Windows\CurrentVersion\Exp lore r \Shell Folders", _
"Desktop")
SonunaFlAshEkle Masa
Masa = Masa + Tanitici + ".lnk"
If DosyaVar(Masa) Then Kill Masa
FileCopy KDosya, Masa
DoEvents
End If
’Baslat menüsünden sil
If Check1.Value <> 1 Then
DoEvents
Kill KDosya
End If
DoEvents
WindowsPencereKapat Grup, Me.hwnd
End Sub
Private Sub Command1_Click()
If Check1.Value = 1 Or Check2.Value = 1 Then
KisaYoluYap Text2, Text3, Text1
End If
End Sub
Sub SonunaFlAshEkle(Metin As String)
If Len(Metin) = 0 Then Exit Sub
If Right(Metin, 1) <> "\" Then Metin = Metin + "\"
End Sub
Function DosyaVar(sFileName As String) As Boolean
If Len(sFileName) = 0 Then
DosyaVar = False
Exit Function
End If
If Len(Dir(sFileName)) Then
DosyaVar = True
Else
DosyaVar = False
End If
End Function

__________________

BeLqide bu dünya başqa bir gezegenin cehennemidir..!!?

SEN GİDİNCE YALNIZ KALACAĞIM.YALNIZLIKTAN KORKMUYORUM DA YA CANIM ELLERİNİ TUTMAK İSTERSE..

SiLemıyosaN KaRaLayacaksıN...GideRkeN Kaç Kere BaktıN ArkaNa?