BAŞLIKSIZ FORMU HAREKET ETTİRMEK

Visual Basic de basligi olmayan bir formu Fare ile hareket ettiremeyiz. Iste Buna Api ile bir cözüm

Option Explicit

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function SendMessage Lib "user32"Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg _
As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_SYSCOMMAND = &H112

Private Sub label1_MouseDown(Button As Integer, Shift As _
Integer, X As Single, Y As Single)

Call ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

Private Sub Command1_Click()
Unload Me
End Sub

CTRL+ALT+DEL TUŞLARINI İPTAL ETMEK
Bu Kod sayesinde Windows da Ctrl-Alt-Del tuslari iptal edilir.

Option Explicit

Private Declare Function SystemParametersInfo Lib _
"User32"Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As _
Long, ByVal lpvParam As Any, ByVal fuWinIni _
As Long) As Long

Private Sub Command1_Click()
Dim Sonuc&
Sonuc= SystemParametersInfo(97, True, "1", 0)
Label1.Caption = "[Ctrl] + [Alt] + [Del] iptal edildi"
End Sub

Private Sub Command2_Click()
Dim Sonuc&
Sonuc = SystemParametersInfo(97, False, "1", 0)
Label1.Caption = "[Ctrl] + [Alt] + [Del] aktif"
End Sub

Private Sub Form_Load()
Call Command2_Click
End Sub

DOSYA TRANSFERİ
Bu Kod sayesinde winsock kontrolü üzerinden dosya transferi yapabiliriz. Büyük boyuttaki dosyalari gönderebilmemiz icin bunlari kücük parcalara bölüp göndermemiz gerekiyor. Gönderildigi yerde yeniden birlestirilmesi gerekiyor. Ayrica bi kanaldan bir dosya gönderirken diger bir kanaldan bir dosya alabiliriz. Bu durumda port degistirmemiz gerekiyor.

'-------------------- Kod Form1 --------------------

Option Explicit

Const ResponseTimeOut = 20 '20 Saniye
Const PaketSize = 2048

Dim Start&
Dim OkFlag As Boolean
Dim TimeOut As Boolean
Dim Connected As Boolean

Private Sub Form_Load()
Timer1.Enabled =a False
Timer1.Interval = 400
Winsock1.LocalPort = CInt(Text1.Text)
Winsock1.Listen

Label2.Caption = "Bagli degil"
Label3.Caption = App.Path & "\deneme.bmp"

If Dir$(Label3.Caption) <> ""Then
Label4.Caption = Int((FileLen(Label3.Caption) / 1024) * 10) _
/ 10 & " kB"
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload Form2
End Sub

Private Sub Command1_Click()
Call SendFile(Label3.Caption)
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub

Private Sub File1_Click()
Dim AA$, BB$

AA = File1.Path
If Right$(AA, 1) <> "\"And Right$(AA, 1) <> "/"Then
AA = AA & "\"
End If

Label3.Caption = AA & File1.FileName
Label4.Caption = Int((FileLen(Label3.Caption) / 1024) * 10) _
/ 10 & " kB"
End Sub

Private Sub Timer1_Timer()
If Timer - Start > ResponseTimeOut Then
TimeOut = True
OkFlag = False
End If
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock1.Accept requestID
Winsock1.SendData 77
Label2.Caption = "Baglanti Hazir"
Connected = True
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim Data() As Byte

Winsock1.GetData Data, vbString
If Data(0) = 77 Then
OkFlag = False
End If
End Sub

Private Sub SendFile(FileName$)
Dim Data() As Byte
Dim l&, AA$, BB$, x&, FN%, TM As Single

On Error Resume Next

If Not Connected Then
MsgBox ("Istemciye Baganti Kurulamiyor!")
Exit Sub
End If

Call Disable
l = FileLen(FileName)
AA = Hex(l)
Do While Len(AA) < 8
AA = "0" & AA
Loop

BB = LastPath(FileName)
BB = BB & Space$(257 - Len(BB))
AA = "New Data|" & AA & BB
ReDim Data(0 To Len(AA) - 1)
For x = 1 To Len(AA)
Data(x - 1) = Asc(Mid$(AA, x, 1))
Next x

Winsock1.SendData Data

If WaitForResponse Then
FN = FreeFile
Open FileName For Binary As #FN
ReDim Data(1 To PaketSize) As Byte

Label2.Caption = "Veri Gönder"
Label2.Refresh

l = LOF(FN)
TM = Timer
For x = 1 To l \ PaketSize
Get #FN, , Data
Winsock1.SendData Data
Call ProgressBar(x * PaketSize, 0, l)
Label5.Caption = Int(x * PaketSize / 1024 / (Timer - TM) * _
10) / 10 & " kB/Sec"

Label5.Refresh
If Not WaitForResponse Then
MsgBox ("Transfer Hatasi")
Call ProgressBar(0, 0, l)
Label2.Caption = "Baglanti Hazir"
Call Enable
Exit Sub
End If
Next x

If l Mod PaketSize <> 0 Then
ReDim Data(1 To l Mod PaketSize) As Byte
Get #FN, , Data
Winsock1.SendData Data
Call ProgressBar(l, 0, l)
Label5.Caption = Int(x * PaketSize / 1024 / (Timer - TM) * _
10) / 10 & " kB/Sec"

Label5.Refresh
If Not WaitForResponse Then
MsgBox ("Transfer Hatasi")
Call ProgressBar(0, 0, l)
Label2.Caption = "Baglanti Hazir"
Call Enable
Exit Sub
End If
End If

Close FN
Label2.Caption = "Baglanti Hazir"
Call ProgressBar(0, 0, l)
Else
Label2.Caption = "Timeout"
MsgBox ("Baglanti Kurulamadi!")
End If
Call Enable
End Sub

Private Function WaitForResponse() As Boolean
OkFlag = True
TimeOut = False
Start = Timer
Timer1.Enabled = True
Do While OkFlag
DoEvents
Loop
If Not TimeOut Then WaitForResponse = True
Timer1.Enabled = False
End Function

Private Sub ProgressBar(ByVal Prg&, ByVal Min&, ByVal Max&)
Dim Fx&
Static LastX
If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub
Prg = Int(100 / (Max - Min) * (Prg - Min))
With Picture1

If Prg > 0 Then
If Prg <> LastX Then
Picture1.Cls
Fx = (Picture1.ScaleWidth - 2) / 100 * Prg
Picture1.Line (0, 0)-(Fx + 1, Picture1.ScaleHeight _
- 1), &H8000000D, BF
.CurrentX = Fx + 3
.CurrentY = 0
Picture1.Print Trim$(CStr(Prg) & " %")
LastX = Prg
End If
Else
Picture1.Cls
End If
End With
End Sub

Private Function LastPath(ByVal Path$) As String
Dim AA$, BB$, x&
For x = Len(Path) To 1 Step -1
AA = Mid$(Path, x, 1)
If AA = "/"Or AA = "\"Then
Exit For
Else
BB = AA & BB
End If
Next x
LastPath = BB
End Function

Private Sub Disable()
Text1.Enabled = False
Command1.Enabled = False
File1.Enabled = False
Dir1.Enabled = False
Drive1.Enabled = False
MousePointer = vbHourglass
End Sub

Private Sub Enable()
Text1.Enabled = True
Command1.Enabled = True
File1.Enabled = True
Dir1.Enabled = True
Drive1.Enabled = True
MousePointer = vbDefault
End Sub

'--------------------- Kod Form1 Bitis--------------------------

'-------------------- Kod Form2 Baslangic--------------------

Option Explicit

Const ResponseTimeOut = 20 '20 Saniye

Dim Start&
Dim OkFlag As Boolean
Dim TimeOut As Boolean
Dim Connected As Boolean
Dim Awaiting As Boolean

Private Sub Form_Load()
Timer1.Enabled = False
Timer1.Interval = 400

Drive1.Drive = "c:"
Dir1.Path = "c:"

With Form1
.Show
.Top = Screen.Height / 2
.Left = (Screen.Width - .Width) / 2
End With

With Me
.Left = Form1.Left
.Top = Form1.Top - .Height
End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload Form1
End Sub

Private Sub Command1_Click()
On Error Resume Next
Winsock1.Connect Text2.Text, CInt(Text1.Text)

Awaiting = True
If WaitForResponse Then
Label1.Caption = "Baglanti Hazir"
Command1.Enabled = False
Else
MsgBox ("Sunucuya baglanti Kurulamadi")
Winsock1.Close
End If
Awaiting = False
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Private Sub Dir1_Change()
Dim AA$

AA = Dir1.Path
If Right$(AA, 1) <> "\"And Right$(AA, 1) <> "/"Then
AA = AA & "\"
End If
Label8.Caption = AA
File1.Path = Dir1.Path
End Sub

Private Sub Timer1_Timer()
If Timer - Start > ResponseTimeOut Then
TimeOut = True
OkFlag = False
End If
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim Data() As Byte
Dim AA$, BB$, x&, d As Single
Static Rec As Boolean
Static TotalLen&
Static IsLen&
Static FN%
Static TM As Single

Winsock1.GetData Data, vbString
If Awaiting Then
If Data(0) = 77 Then OkFlag = False
Else
If UBound(Data) = 273 And Not Rec Then
For x = 0 To UBound(Data)
AA = AA & Chr$(Data(x))
Next x

If Left$(AA, 9) = "New Data|"Then
TotalLen = CLng("&H" & Mid$(AA, 10, Cool)
If TotalLen <> 0 Then
BB = Trim$(Mid$(AA, 1Cool)
Label1.Caption = "Empfange die Datei " & Chr$(34) & _
BB & Chr$(34)

Label4.Caption = Int((TotalLen / 1024) * 10) / 10 & _
" kB"

Call Dir1_Change
Label8.Caption = Label8.Caption & BB
TM = Timer
Call Disable
Else
TotalLen = 0
End If
End If

If TotalLen <> 0 Then
Winsock1.SendData 77
Rec = True
FN = FreeFile
IsLen = 0
If Dir$(Label8.Caption) <> ""Then
Kill Label8.Caption
End If
Open Label8.Caption For Binary As #FN
End If
ElseIf Rec Then
Put #FN, , Data
IsLen = IsLen + UBound(Data) + 1

d = (Timer - TM)
If d <> 0 Then Label3.Caption = Int(IsLen / 1024 / _
d * 10) / 10 & " kB/Sec"

Call ProgressBar(IsLen, 0, TotalLen)
If IsLen = TotalLen Then
Close FN
MsgBox ("Transfer Basariyla Tamamlandi!")
Call ProgressBar(0, 0, TotalLen)
Rec = False
Call Enable
TotalLen = 0
File1.Refresh
BB = LastPath(Label8.Caption)
If File1.ListCount > 0 Then
For x = 0 To File1.ListCount - 1
If File1.List(x) = BB Then
File1.ListIndex = x
Exit For
End If
Next x
Label1.Caption = "Baglanti Hazir"
End If
End If
Winsock1.SendData 77
End If
End If
End Sub

Private Sub ProgressBar(ByVal Prg&, ByVal Min&, ByVal Max&)
Dim Fx&
Static LastX
If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub
Prg = Int(100 / (Max - Min) * (Prg - Min))
With Picture1

If Prg > 0 Then
If Prg <> LastX Then
Picture1.Cls
Fx = (Picture1.ScaleWidth - 2) / 100 * Prg
Picture1.Line (0, 0)-(Fx + 1, Picture1.ScaleHeight _
- 1), &H8000000D, BF

.CurrentX = Fx + 3
.CurrentY = 0
Picture1.Print Trim$(CStr(Prg) & " %")
LastX = Prg
End If
Else
Picture1.Cls
End If
End With
End Sub

Private Function WaitForResponse() As Boolean
OkFlag = True
TimeOut = False
Start = Timer
Timer1.Enabled = True
Do While OkFlag
DoEvents
Loop
If Not TimeOut Then WaitForResponse = True
Timer1.Enabled = False
End Function

Private Function LastPath(ByVal Path$) As String
Dim AA$, BB$, x&
For x = Len(Path) To 1 Step -1
AA = Mid$(Path, x, 1)
If AA = "/"Or AA = "\"Then
Exit For
Else
BB = AA & BB
End If
Next x
LastPath = BB
End Function

Private Sub Disable()
Text1.Enabled = False
Text2.Enabled = False
Dir1.Enabled = False
Drive1.Enabled = False
MousePointer = vbHourglass
End Sub

Private Sub Enable()
Text1.Enabled = True
Text2.Enabled = True
Dir1.Enabled = True
Drive1.Enabled = True
MousePointer = vbDefault
End Sub