Visual Hazır Kodlar

Windows'u istenen sürede kapatan digital göstergeli program.



Belirli süre sonunda Windows'u kapatıyor.Ayrıca içinde ister form üzerine veya herhangi başka bir bölüm üzerine digital rakam koymaya yarayacak kodlar var.

frx dosyasını gönderemediğimden düğmeleri tarif ederek başlayayım. Üstteki altlı üstlü 3'er den 6 düğme soldan sağa saat, dakika ve saniyeyi arttırıp azaltan düğmeler. Düğmeye basılı tutunca rakam otomatik olarak artıyor. Altta yanyana duran 3 düğme soldan sağa durdurma, başlatma ve programdan çıkış düğmeleri, grubun sağındaki düğme de programı aşağı çeken düğme. Sayıları arttırmadan ortadaki düğmeye kesinlikle basmayın windows kapanır.Sayıları makul miktarda arttırıp alttaki üçlü grubun ortasındaki düğmeye basınca geri sayma işlemi başalayacak ve bittiğinde windows kapanacak.

NotPad'den bir dosya açıp içine aşağıdaki kodları (çizgiye kadar) yazıp winkapan.vbp olarak kaydediyorsunuz.

Type=Exe
Form=winkapan.frm
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\STDOLE2.TL B#OLE Automation
Module=Module1; winkapan.bas
IconForm="winkapan"
Startup="winkapan"
HelpFile=""
ExeName32="winkapan.exe"
Path32="..\..\WINDOWS\Desktop"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Ordon"
CompilationType=0
OptimizationType=0
FavorPentiumPro™=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[MS Transaction Server]
Auto*******=1

'_____________________________________________
Buradan aşağıdaki kodları (çizgiye kadar) yine notpad'e yazıp winkapan.frm diye kaydediyorsunuz.


VERSION 5.00
Begin VB.Form winkapan
AutoRedraw = -1 'True
BackColor = &H80000007&
BorderStyle = 1 'Fixed Single
ClientHeight = 1680
ClientLeft = 15
ClientTop = 15
ClientWidth = 2700
ClipControls = 0 'False
ControlBox = 0 'False
Icon = "winkapan.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 112
ScaleMode = 3 'Pixel
ScaleWidth = 180
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton Command17
Height = 255
Left = 2040
Style = 1 'Graphical
TabIndex = 16
Top = 1320
Width = 255
End
Begin VB.CommandButton Command16
Height = 255
Left = 2520
Style = 1 'Graphical
TabIndex = 15
Top = 1440
Width = 255
End
Begin VB.CommandButton Command15
Height = 255
Left = 2520
Style = 1 'Graphical
TabIndex = 14
Top = 1200
Width = 255
End
Begin VB.CommandButton Command14
Height = 255
Left = 2520
Style = 1 'Graphical
TabIndex = 13
Top = 960
Width = 255
End
Begin VB.CommandButton Command13
Height = 255
Left = 2520
Style = 1 'Graphical
TabIndex = 12
Top = 720
Width = 255
End
Begin VB.CommandButton Command12
Height = 255
Left = 2520
Style = 1 'Graphical
TabIndex = 11
Top = 480
Width = 255
End
Begin VB.CommandButton Command11
Height = 255
Left = 2520
Style = 1 'Graphical
TabIndex = 10
Top = 240
Width = 255
End
Begin VB.CommandButton Command10
Appearance = 0 'Flat
BackColor = &H008080FF&
Height = 255
Left = 2520
MaskColor = &H00C0C0FF&
Style = 1 'Graphical
TabIndex = 9
Top = 0
Width = 255
End
Begin VB.Timer Timer2
Left = 1800
Top = 600
End
Begin VB.CommandButton Command9
Height = 195
Left = 1440
Picture = "winkapan.frx":0442
Style = 1 'Graphical
TabIndex = 8
Top = 480
Width = 255
End
Begin VB.CommandButton Command8
Height = 195
Left = 1440
Picture = "winkapan.frx":059C
Style = 1 'Graphical
TabIndex = 7
Top = 240
Width = 255
End
Begin VB.CommandButton Command7
Height = 195
Left = 1080
Picture = "winkapan.frx":06F6
Style = 1 'Graphical
TabIndex = 6
Top = 480
Width = 255
End
Begin VB.CommandButton Command6
Height = 195
Left = 1080
Picture = "winkapan.frx":0850
Style = 1 'Graphical
TabIndex = 5
Top = 240
Width = 255
End
Begin VB.CommandButton Command2
Height = 195
Left = 720
Picture = "winkapan.frx":09AA
Style = 1 'Graphical
TabIndex = 4
Top = 480
Width = 255
End
Begin VB.CommandButton Command1
Height = 195
Left = 720
Picture = "winkapan.frx":0B04
Style = 1 'Graphical
TabIndex = 3
Top = 240
Width = 255
End
Begin VB.Timer Timer1
Left = 1800
Top = 240
End
Begin VB.CommandButton Command5
Height = 255
Left = 1320
Picture = "winkapan.frx":0C5E
Style = 1 'Graphical
TabIndex = 2
Top = 1320
Width = 255
End
Begin VB.CommandButton Command4
Height = 255
Left = 1080
Picture = "winkapan.frx":0E30
Style = 1 'Graphical
TabIndex = 1
Top = 1320
Width = 255
End
Begin VB.CommandButton Command3
Height = 255
Left = 840
Picture = "winkapan.frx":0FAA
Style = 1 'Graphical
TabIndex = 0
Top = 1320
Width = 255
End
Begin VB.Shape Shape1
FillColor = &H00E0E0E0&
FillStyle = 0 'Solid
Height = 135
Index = 3
Left = 0
Shape = 3 'Circle
Top = 0
Width = 135
End
Begin VB.Shape Shape1
FillColor = &H00E0E0E0&
FillStyle = 0 'Solid
Height = 135
Index = 2
Left = 0
Shape = 3 'Circle
Top = 0
Width = 135
End
Begin VB.Shape Shape1
FillColor = &H00E0E0E0&
FillStyle = 0 'Solid
Height = 135
Index = 1
Left = 0
Shape = 3 'Circle
Top = 0
Width = 135
End
Begin VB.Shape Shape1
FillColor = &H00E0E0E0&
FillStyle = 0 'Solid
Height = 135
Index = 0
Left = 0
Shape = 3 'Circle
Top = 0
Width = 135
End
End
Attribute VB_Name = "winkapan"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim saniye, dakika, saat, düğme As Integer
Dim renk(7)
Dim parlak
Dim mat
Dim kod As Integer
Private Sub hareket(frm As Form)
Dim xx As Long
ReleaseCapture
xx = SendMessage(frm.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)

End Sub

Private Sub çiz(x, y, say, tip)

Select Case tip
Case 1
parlak = &HFF&
mat = &H80&
Case 2
mat = &H8080&
parlak = &HFFFF&
Case 3
mat = &H8000&
parlak = &HFF00&
Case 4
mat = &H808000
parlak = &HFFFF00
Case 5
mat = &H808080
parlak = &HFFFFFF
Case 6
mat = &H800000
parlak = &HFF0000
Case 7
mat = &H800080
parlak = &HFF00FF
End Select




If say = 10 Then
For q = 1 To 7
renk(q) = mat
Next
End If

If say = 0 Or say = 3 Or say = 2 Or say = 5 Or say = 6 Or say = 7 Or say = 8 Or say = 9 Then
renk(1) = parlak
Else
renk(1) = mat
End If

If say = 0 Or say = 3 Or say = 2 Or say = 5 Or say = 6 Or say = 8 Or say = 9 Then
renk(2) = parlak
Else
renk(2) = mat
End If

If say = 3 Or say = 2 Or say = 4 Or say = 5 Or say = 6 Or say = 8 Or say = 9 Then
renk(3) = parlak
Else
renk(3) = mat
End If

If say = 0 Or say = 4 Or say = 5 Or say = 6 Or say = 8 Or say = 9 Then
renk(4) = parlak
Else
renk(4) = mat
End If

If say = 0 Or say = 2 Or say = 6 Or say = 8 Then
renk(5) = parlak
Else
renk(5) = mat
End If

If say = 0 Or say = 1 Or say = 3 Or say = 2 Or say = 4 Or say = 7 Or say = 8 Or say = 9 Then
renk(6) = parlak
Else
renk(6) = mat
End If

If say = 0 Or say = 3 Or say = 1 Or say = 4 Or say = 5 Or say = 6 Or say = 7 Or say = 8 Or say = 9 Then
renk(7) = parlak
Else
renk(7) = mat
End If

Shape1(0).Left = 53
Shape1(1).Left = 53
Shape1(2).Left = 105
Shape1(3).Left = 105
Shape1(0).Top = 55
Shape1(1).Top = 70
Shape1(2).Top = 55
Shape1(3).Top = 70
'Shape1(0).FillColor = parlak
'Shape1(1).FillColor = parlak
'Shape1(2).FillColor = parlak
'Shape1(3).FillColor = parlak

'üst
Line (x + 2, y)-(x + 16, y), renk(1)
Line (x + 2, y + 1)-(x + 16, y + 1), renk(1)
Line (x + 3, y + 2)-(x + 15, y + 2), renk(1)
Line (x + 4, y + 3)-(x + 14, y + 3), renk(1)

'alt
Line (x + 4, y + 31)-(x + 14, y + 31), renk(2)
Line (x + 3, y + 32)-(x + 15, y + 32), renk(2)
Line (x + 2, y + 33)-(x + 16, y + 33), renk(2)
Line (x + 2, y + 34)-(x + 16, y + 34), renk(2)

'orta
Line (x + 3, y + 15)-(x + 15, y + 15), renk(3)
Line (x + 2, y + 16)-(x + 16, y + 16), renk(3)
Line (x + 1, y + 17)-(x + 17, y + 17), renk(3)
Line (x + 2, y + 18)-(x + 16, y + 18), renk(3)
Line (x + 3, y + 19)-(x + 15, y + 19), renk(3)

'solüst
Line (x, y + 2)-(x, y + 15), renk(4)
Line (x + 1, y + 2)-(x + 1, y + 15), renk(4)
Line (x + 2, y + 3)-(x + 2, y + 14), renk(4)
Line (x + 3, y + 4)-(x + 3, y + 13), renk(4)

'solalt
Line (x, y + 19)-(x, y + 32), renk(5)
Line (x + 1, y + 19)-(x + 1, y + 32), renk(5)
Line (x + 2, y + 20)-(x + 2, y + 31), renk(5)
Line (x + 3, y + 21)-(x + 3, y + 30), renk(5)

'sağüst
Line (x + 15, y + 4)-(x + 15, y + 13), renk(6)
Line (x + 16, y + 3)-(x + 16, y + 14), renk(6)
Line (x + 17, y + 2)-(x + 17, y + 15), renk(6)
Line (x + 18, y + 2)-(x + 18, y + 15), renk(6)

'sağalt
Line (x + 15, y + 21)-(x + 15, y + 30), renk(7)
Line (x + 16, y + 20)-(x + 16, y + 31), renk(7)
Line (x + 17, y + 19)-(x + 17, y + 32), renk(7)
Line (x + 18, y + 19)-(x + 18, y + 32), renk(7)

End Sub

'Private Sub Command1_Click(Index As Integer)
'saniye yukarı
'saniye = saniye + 1
'If saniye = 60 Then saniye = 0
'Call ayarla
'End Sub
Private Function sayıbul(s, sa)
If s = 1 Then
sayıbul = sa - (Fix(sa / 10) * 10)
Else
sayıbul = Fix(sa / 10)
If sayıbul = 0 Then sayıbul = 10
End If
End Function
Private Sub ayarla()

Call çiz(10, 50, sayıbul(2, saat), kod)
Call çiz(32, 50, sayıbul(1, saat), kod)
Call çiz(62, 50, sayıbul(2, dakika), kod)
Call çiz(84, 50, sayıbul(1, dakika), kod)
Call çiz(114, 50, sayıbul(2, saniye), kod)
Call çiz(136, 50, sayıbul(1, saniye), kod)

End Sub

Private Sub Command1_Click()
'form1.AutoRedraw = False
'saat = saat + 1
'If saat = 100 Then saat = 0
'Call ayarla
End Sub

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
düğme = 5
Timer2.Interval = 99

End Sub

Private Sub Command1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer2.Interval = 0
End Sub

Private Sub Command10_Click()
kod = 1

'form1.AutoRedraw = False
Call ekran(kod)

End Sub

Private Sub Command11_Click()
kod = 2
'form1.AutoRedraw = False
Call ekran(kod)

End Sub

Private Sub Command12_Click()
kod = 3
'form1.AutoRedraw = False
Call ekran(kod)

End Sub

Private Sub Command13_Click()
kod = 4
'form1.AutoRedraw = False
Call ekran(kod)

End Sub

Private Sub Command14_Click()
kod = 5
'form1.AutoRedraw = False
Call ekran(kod)

End Sub

Private Sub Command15_Click()
kod = 6
'form1.AutoRedraw = False
Call ekran(kod)

End Sub

Private Sub Command16_Click()
kod = 7
'form1.AutoRedraw = False
Call ekran(kod)

End Sub

Private Sub Command17_Click()
kapan = 1
winkapan.WindowState = 1
End Sub

Private Sub Command2_Click()
'form1.AutoRedraw = False
'saat = saat - 1
'If saat = -1 Then saat = 99
'Call ayarla

End Sub

Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
düğme = 6
Timer2.Interval = 99

End Sub

Private Sub Command2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer2.Interval = 0
End Sub

Private Sub Command3_Click()
Shape1(0).FillColor = parlak
Shape1(1).FillColor = parlak
Shape1(2).FillColor = parlak
Shape1(3).FillColor = parlak

Timer1.Interval = 0
Command3.Enabled = False
Command4.Enabled = True
Command1.Visible = True
Command2.Visible = True
Command6.Visible = True
Command7.Visible = True
Command8.Visible = True
Command9.Visible = True

End Sub

Private Sub Command4_Click()
Command3.Enabled = True
Command4.Enabled = False
Command1.Visible = False
Command2.Visible = False
Command6.Visible = False
Command7.Visible = False
Command8.Visible = False
Command9.Visible = False

Timer1.Interval = 1000

End Sub

'Private Sub Command2_Click(Index As Integer)
'saniye = saniye - 1
'If saniye = -1 Then saniye = 59
'Call ayarla
'End Sub

Private Sub Command5_Click()
Unload Me
End Sub

Private Sub Command6_Click()
'form1.AutoRedraw = False
'dakika = dakika + 1
'If dakika = 60 Then saniye = 0
'Call ayarla

End Sub

Private Sub Command6_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
düğme = 3
Timer2.Interval = 99

End Sub

Private Sub Command6_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer2.Interval = 0
End Sub

Private Sub Command7_Click()
''form1.AutoRedraw = False
'dakika = dakika - 1
'If dakika = -1 Then dakika = 59
'Call ayarla
End Sub

Private Sub Command7_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
düğme = 4
Timer2.Interval = 99

End Sub

Private Sub Command7_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer2.Interval = 0
End Sub

Private Sub Command8_Click()
'form1.AutoRedraw = False
'saniye yukarı
'saniye = saniye + 1
End Sub

Private Sub Command8_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
'hızlı yukarı çıkma
düğme = 1
Timer2.Interval = 99

End Sub

Private Sub Command8_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer2.Interval = 0
End Sub

Private Sub Command9_Click()
'form1.AutoRedraw = False
saniye = saniye - 1
If saniye = -1 Then saniye = 59
Call ayarla
End Sub

Private Sub Command9_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
düğme = 2
Timer2.Interval = 99

End Sub

Private Sub Command9_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Timer2.Interval = 0
End Sub


Private Sub Form_Load()
Command17.Picture = Command9.Picture
If App.PrevInstance = True Then End
Command3.Enabled = False
Call çiz(10, 50, 10, 1)
Call çiz(32, 50, 0, 1)
Call çiz(62, 50, 10, 1)
Call çiz(84, 50, 0, 1)
Call çiz(114, 50, 10, 1)
Call çiz(136, 50, 0, 1)

Command1.Left = 10 + 14
Command2.Left = 10 + 14

Command6.Left = 62 + 14
Command7.Left = 62 + 14

Command8.Left = 114 + 14
Command9.Left = 114 + 14
'Shape1(0).Visible = False
'Shape1(1).Visible = False
'Shape1(2).Visible = False
'Shape1(3).Visible = False

Shape1(0).FillColor = parlak
Shape1(1).FillColor = parlak
Shape1(2).FillColor = parlak
Shape1(3).FillColor = parlak


Command10.BackColor = &HFF&
Command11.BackColor = &HFFFF&
Command12.BackColor = &HFF00&
Command13.BackColor = &HFFFF00
Command14.BackColor = &HFFFFFF
Command15.BackColor = &HFF0000
Command16.BackColor = &HFF00FF


End Sub
Private Sub winkapa()
Dim nesne As Long
nesne = ExitWindowsEx(1, 0)
End
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then hareket Me
End Sub

Private Function ekran(xx)
Select Case xx
Case 1
parlak = &HFF&
Case 2
parlak = &HFFFF&
Case 3
parlak = &HFF00&
Case 4
parlak = &HFFFF00
Case 5
parlak = &HFFFFFF
Case 6
parlak = &HFF0000
Case 7
parlak = &HFF00FF
End Select
Shape1(0).FillColor = parlak
Shape1(1).FillColor = parlak
Shape1(2).FillColor = parlak
Shape1(3).FillColor = parlak
'form1.AutoRedraw = False
Call ayarla
End Function

Private Sub Form_Resize()
'If Top = 45000 Then
'kapan = 1
'Else
'kapan = 0
'Caption = ""
'Width = 2710
'Height = 1710
'End If
End Sub

Private Sub Timer1_Timer()
'Geri sayım başlayacak

'If Shape1(0).FillColor = parlak Then Shape1(0).FillColor = mat else shape


If Shape1(0).FillColor = parlak Then
Shape1(0).FillColor = mat
Shape1(1).FillColor = mat
Shape1(2).FillColor = mat
Shape1(3).FillColor = mat
Else
Shape1(0).FillColor = parlak
Shape1(1).FillColor = parlak
Shape1(2).FillColor = parlak
Shape1(3).FillColor = parlak
End If

saniye = saniye - 1
If saniye = -1 Then
saniye = 59
dakika = dakika - 1
End If
If dakika = -1 Then
dakika = 59
saat = saat - 1
End If
If saniye < 10 Then Call Beep(15000, 1)

If saat = -1 Then
Call winkapa
Timer1.Interval = 0
Else
Call ayarla
End If
If kapan = 1 Then Caption = "Winkapan " + CStr(Val(saat)) + ":" + CStr(Val(dakika)) + ":" + CStr(Val(saniye))

End Sub

Private Sub Timer2_Timer()
'form1.AutoRedraw = False
Select Case düğme
Case 1
saniye = saniye + 1
If saniye = 60 Then saniye = 0
Case 2
saniye = saniye - 1
If saniye = -1 Then saniye = 59
Case 3
dakika = dakika + 1
If dakika = 60 Then dakika = 0
Case 4
dakika = dakika - 1
If dakika = -1 Then dakika = 59
Case 5
saat = saat + 1
If saat = 100 Then saat = 0
Case 6
saat = saat - 1
If saat = -1 Then saat = 99
End Select
Call ayarla
If Timer2.Interval = 99 Then Timer2.Interval = 500: Exit Sub
If Timer2.Interval > 100 Then
Timer2.Interval = Timer2.Interval - 100
End If


End Sub

'_________________________________________________ ______________
Buradan aşağıdaki kodları (çizgiye kadar) notpad'e yazıp winkapan.bas olarak kaydediyorsunuz.


Attribute VB_Name = "Module1"
Public Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uflags As Long, ByVal dwreserved As Long) As Long
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
Public kapan As Integer
Public saat As Integer
Public dakika As Integer
Public saniye As Integer
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal IParam As Long) As Long

Public Declare Sub ReleaseCapture Lib "user32" ()

'_________________________________________________ __________________
Buradan aşağıdaki yazıları da winkapan.wbw olarak kaydediyorsunuz.

winkapan = 66, 66, 419, 418, , 44, 44, 397, 396, C
Module1 = 88, 88, 466, 440,


Bu kadar.
Özellikle digital sayıları programlarında herhangi bir ocx kullanmadan göstermek isteyenler için yararlı olacağı kanısındayım.

Chat programı

Titreşim özeliğide var

Option Explicit

Dim received As String, received2 As String
Dim oldLeft As Integer, oldTop As Integer
Dim kiprama As Integer
Dim pPort As Integer

Private Sub Client1_Close()
Command2.Enabled = True
End Sub

Private Sub Client1_Connect()
Text1.Text = Text1.Text & "Karşı Tarafa Bağlanıldı. " & Now & vbCrLf
Command2.Enabled = False
End Sub

Private Sub Command1_Click()
Command1.Default = True
If Client1.State = sckConnected And Trim(Text2) <> "" Then
Client1.SendData "MSG" & Text4.Text & ">" & Text2.Text & vbCrLf
TxGelen.Text = TxGelen.Text & Text4.Text & ">" & Text2.Text & vbCrLf
Text2.Text = ""
End If
Text2.SetFocus
End Sub

Private Sub Command2_Click()
Client1.RemoteHost = Text3.Text
Client1.RemotePort = pPort
Client1.Connect
End Sub

Private Sub Command3_Click()
If Client1.State = sckConnected Then
Client1.SendData "CMD01" & vbCrLf
Text1.Text = Text1.Text & "Titreşim Gönderdiniz.." & Now & vbCrLf
End If
Text2.SetFocus
End Sub

Private Sub Form_Load()
Randomize Timer
pPort = 1498
Server1.LocalPort = pPort
Server1.Listen

Text1.Text = Server1.LocalPort & ". portta hazır.." & vbCrLf
End Sub

Private Sub Server1_Close()
Client1.Close
Server1.Close
Server1.Listen
End Sub

Private Sub Server1_Connect()
Text1.Text = Text1.Text & Server1.RemoteHost & " Bağlandı. " & Now & vbCrLf
End Sub
'Public frm1 As Form1
Private Sub Server1_ConnectionRequest(ByVal requestID As Long)
If Server1.State <> sckConnected Then
Server1.Close
Server1.Accept requestID
Command2.Enabled = False
Text1.Text = Text1.Text & requestID & " Id ile bağlantı alındı. " & Now & vbCrLf
' Dim frm1 As New Form1
' pPort = pPort + 1
' frm1.Show
If Client1.State = sckClosed Then
Client1.RemoteHost = Server1.RemoteHostIP
Client1.RemotePort = pPort
Client1.Connect
End If
End If
End Sub

Private Sub Server1_DataArrival(ByVal bytesTotal As Long)
Dim tmp_received As String

Server1.GetData tmp_received

received = received & tmp_received
tmp_received = ""

If InStr(received, vbCrLf) > 0 Then
tmp_received = Left(received, InStr(received, vbCrLf) - 1)
received = Mid(received, InStr(received, vbCrLf) + 2)
End If

' If tmp_received <> "" And Len(tmp_received) < 4 Then Server1.Close ' Protocol e uymadığın için bağlantıyı kestik..

If tmp_received <> "" Then
Select Case UCase(Left(tmp_received, 3))
Case "MSG": TxGelen.Text = TxGelen.Text & Mid(tmp_received, 4) & vbCrLf
Case "CMD": Call KomutIsle(Mid(tmp_received, 4))
Case Else: Server1.Close
End Select
End If
End Sub

Private Sub Text1_Change()
Text1.SelStart = Len(Text1.Text)
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = 0 ' Değiştirilememesi için
End Sub

Private Sub Text4_LostFocus()
If Text4.Text = "" Then Text4.Text = "Guest" & Int(Rnd * 18000)
End Sub

Private Sub Timer1_Timer()
kiprama = kiprama + 1

Left = Left - Rnd * 100
Top = Top + Rnd * 177

Left = Left + Rnd * 100
Top = Top - Rnd * 177

If kiprama = 38 Then Timer1.Enabled = False: kiprama = 0: Form1.Left = oldLeft: Form1.Top = oldTop
End Sub

Private Function KomutIsle(cmd As String)
Select Case cmd
Case "01"
oldLeft = Left: oldTop = Top: Timer1.Enabled = True
Text1.Text = Text1.Text & "Bir Titreşim Aldınız.." & Now & vbCrLf
Case Else:
End Select
End Function

Private Sub TxGelen_Change()
TxGelen.SelStart = Len(TxGelen.Text)
End Sub

''''''''''''
' msg = mesaj
' cmd = komut
''''''''''''
Windowsun "Başlat" yazısını değiştirin...


Çok kısa ve çok kolay bir kod. Aşağıdakileri direk kopyalayıp programınızı henem oluşturabilirsiniz...

Programın derlenmiş halini buradan indirebilirsiniz...


Bir form oluşturun ve form üzerine;

1 adet command button
1 adet textbox
1 adet label
ekleyin ve isimlerini değiştirmeyin...


Form içine aşağıdakileri direk olarak kopyalayın...
--------------------------------------------------------------------------

Dim wnd As Long, tWnd As Long


Private Sub Command1_Click()
Dim dummy() As Byte

ReDim dummy(Len(Text1) + 1)

dummy = StringToByteArray(Text1.Text)

Call SendMessage(wnd, WM_SETTEXT, 0&, dummy(0))

End Sub

Private Sub exx_Click()
Unload Me
End
End Sub

Private Sub Form_Load()
'Find the taskbar window , Shell_TrayWnd
tWnd = FindWindow("Shell_TrayWnd", "")

'5 stands for GW_CHILD or GW_MAX
wnd = GetWindow(tWnd, 5)

'Start button child hwnd = 196668
Label1.Caption = wnd
End Sub
------------------------------------------------------------------------------






İkinci olarak da foruma ;
1 adet module ekleyin. Onun da ismini değiştirmeyin...
Modüle aşağıdaki kodları yapıştırın...

------------------------------------------------------------------------------
Public Const WM_SETTEXT = &HC

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long

Public Function StringToByteArray(str As String) As Variant
Dim bray() As Byte
Dim cnt As Integer
Dim ln As Integer

ln = Len(str)

ReDim bray(ln)

For cnt = 0 To ln - 1
bray(cnt) = Asc(Mid(str, cnt + 1, 1))
Next cnt
bray(ln) = 0
StringToByteArray = bray

End Function
--------------------------------------------
denetim masasına programınızı ekleyin



denetim masasına programınızı ekleyin

merhaba,

yazdığınız programın kontrolerini denetim masasına eklemek istermisiniz?
kolay gelsin,

malzeme listesi : 2 orta boy buton


Option Explicit

Private Declare Function RegCloseKey Lib "advapi32" ( _
ByVal hKey As Long) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32" _
Alias "RegCreateKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal Reserved As Long, _
ByVal lpClass As String, _
ByVal dwOptions As Long, _
ByVal samDesired As Long, _
ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, _
ByRef phkResult As Long, _
ByRef lpdwDisposition As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32" _
Alias "RegOpenKeyExA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
ByRef phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32" _
Alias "RegQueryValueExA" ( _
ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
ByRef lpType As Long, _
ByVal lpData As String, _
ByRef lpcbData As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32" _
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

Private 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

Private Declare Function RegDeleteKey Lib "advapi32.dll" _
Alias "RegDeleteKeyA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" _
Alias "RegCreateKeyA" ( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long


Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3&
Const REG_DWORD = 4


Const REG_OPTION_NON_VOLATILE = 0

Const READ_CONTROL = &H20000
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 KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL


Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004


Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type

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


Private Function UpdateKey(KeyRoot As Long, _
KeyName As String, _
SubKeyName As String, _
SubKeyValue As String) As Boolean

Dim rc As Long
Dim hKey As Long
Dim hDepth As Long
Dim lpAttr As SECURITY_ATTRIBUTES

lpAttr.nLength = 50
lpAttr.lpSecurityDescriptor = 0
lpAttr.bInheritHandle = True


rc = RegCreateKeyEx(KeyRoot, KeyName, 0, REG_SZ, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, _
hKey, hDepth)
If (rc <> ERROR_SUCCESS) Then ***o CreateKeyError

If (SubKeyValue = "") Then

SubKeyValue = " "
End If


rc = RegSetValueEx(hKey, SubKeyName, 0, REG_SZ, _
SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
If (rc <> ERROR_SUCCESS) Then ***o CreateKeyError

rc = RegCloseKey(hKey)


UpdateKey = True
Exit Function

CreateKeyError:

UpdateKey = False

rc = RegCloseKey(hKey)
End Function

Private Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
End If
End If
End Function

Private Function DeleteKey(KeyName As String)
Call ParseKey(KeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegDeleteKey(MainKeyHandle, KeyName)
End If
End Function

Private Function ErrorMsg(lErrorCode As Long) As String
Select Case lErrorCode
Case 1009, 1015
ErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
ErrorMsg = "Bad Key Name"
Case 1011
ErrorMsg = "Can't Open Key"
Case 4, 1012
ErrorMsg = "Can't Read Key"
Case 5
ErrorMsg = "Access to this key is denied"
Case 1013
ErrorMsg = "Can't Write Key"
Case 8, 14
ErrorMsg = "Out of memory"
Case 87
ErrorMsg = "Invalid Parameter"
Case 234
ErrorMsg = "There is more data than the buffer has been allocated to hold."
Case Else
ErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)
End Select
End Function

Private Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function

Private Sub ParseKey(KeyName As String, Keyhandle As Long)
rtn = InStr(KeyName, "\")
If Left(KeyName, 5) <> "HKEY_" Or Right(KeyName, 1) = "\" Then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + KeyName
Exit Sub
ElseIf rtn = 0 Then
Keyhandle = GetMainKeyHandle(KeyName)
KeyName = ""
Else
Keyhandle = GetMainKeyHandle(Left(KeyName, rtn - 1))
KeyName = Right(KeyName, Len(KeyName) - rtn)
End If
End Sub

Private Function SetBinaryValue(SubKey As String, Entry As String, _
Value As String, Optional ByVal DisplayErrorMsg As Boolean = True)

Dim i As Long

Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
lDataSize = Len(Value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(Value, i, 1))
Next
rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, ByteArray(1), lDataSize)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function CreateEntryToSystemPanel(GUID As String, _
Titel As String, _
ToolTipText As String, _
IconDatei As String, _
FileToOpen As String)


UpdateKey HKEY_CLASSES_ROOT, "CLSID\" & GUID, "", Titel
UpdateKey HKEY_CLASSES_ROOT, "CLSID\" & GUID, "InfoTip", ToolTipText
UpdateKey HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\DefaultIcon", "", IconDatei
UpdateKey HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\InProcServer32", "", "shell32.dll"
UpdateKey HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\InProcServer32", "ThreadingModel", "Apartment"
UpdateKey HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\Shell\Open\Command", "", FileToOpen

Dim sKey As String
sKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Exp lore r\"
UpdateKey HKEY_LOCAL_MACHINE, sKey & "Desktop\NameSpace\" & GUID, "", ""
UpdateKey HKEY_LOCAL_MACHINE, sKey & "ControlPanel\NameSpace\" & GUID, "", ""
CreateKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\ShellFolder"
SetBinaryValue "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\ShellFolder", _
"Attributes", Chr$(&H0) + Chr$(&H0) + Chr$(&H0) + Chr$(&H0)
End Function

Public Function DeleteEntryFromSystemPanel(GUID As String)
Dim sKey As String
sKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Exp lore r\"
DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID
DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\DefaultIcon"
DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\InProcServer32"
DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\Shell\Open\Command"
DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\ShellEx\PropertySheetHandlers\" & GUID & ""
DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\ShellFolder"
DeleteKey "HKEY_LOCAL_MACHINE\" & sKey & "\Desktop\NameSpace\" & GUID
DeleteKey "HKEY_LOCAL_MACHINE\" & sKey & "\ControlPanel\NameSpace\" & GUID
End Function

Private Sub Command1_Click()
'------------Denetim masasına giriş ---------------
CreateEntryToSystemPanel "{9d6D8ED6-116D-4D4E-B1C2-87098DB509BA}", _
"dahi çocukk", _
"harikasın evlat", _
App.Path & "\" & "Yourapplication.exe,0", _
App.Path & "\" & "Yourapplication.exe -options"

End Sub
Private Sub Command2_Click()
'---------------- denetim masasından silll ----------------
DeleteEntryFromSystemPanel "{9d6D8ED6-116D-4D4E-B1C2-87098DB509BA}"
End Sub