تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
محتاج مساعدة في اكمال الكود
#1
السلام عليكم
قمت بكتابة كود من اليوتيوب من خلال الفيديو مباشرة
الى ان سطران في حافة الفيدية تحذر رئيتهم
ارجو المساعدة من الاساتذة الكرام
                                                                                                      
           هذا الكود منقوص من نصف السطرين

كود :
Imports System.IO
Imports System.Net
Imports System.Net.Sockets
Imports System.Text

Public Class Form1
   Dim WithEvents Svr As TcpListener
   Dim threadListen As Threading.Thread
   Dim thrC As New List(Of Threading.Thread)
   Dim enc As New System.Text.UTF8Encoding


   Private Sub StartListen()
       While True
           Try
               Dim tc As TcpClient = Svr.AcceptTcpClient
               Dim thr As New Threading.Thread(AddressOf requestHandler)
               thr.Start(New Object() {tc, thrC.Count})
               thrC.Add(thr)
           Catch ex As Exception
               Exit While
           End Try
       End While
   End Sub

   Private Sub requestHandler(ByVal param As Object())
       Dim cln As TcpClient = param(0)
       Dim id As Integer = param(1)
       Dim recv As Integer = 0
       Try
           Do
               Dim b(cln.SendBufferSize) As Byte
               recv = cln.GetStream.Read(b, 0, b.Length)
               Dim cek As String = enc.GetString(b)
               If cek.Contains("GET /") = True Then
                   cek = cek.Replace("GET /", "")
                   cek = cek.Substring(0, cek.IndexOf(" "))
                   Try
                       While True
                           If cek.Contains("%") = True Then
                               Dim code As String = cek.Substring(cek.IndexOf("%") + 1, 2)
                               Dim code_rebuild As String = ChrW(Convert.ToByte(code, 16))
                               cek = cek.Replace("%" & code, code_rebuild)
                           Else
                               Exit While
                           End If
                       End While
                   Catch ex As Exception
                   End Try
                   TextBox1.Text = cek
                   If cek = "" Then
                       cek = "index.html"
                   End If
                   cek = Application.StartupPath & "\HomePage\" & cek
                   Dim ofile = New System.IO.FileInfo(cek)
                   Dim file_Type As String = ""
                   If LCase(cek).Contains(".") = True Then
                       Dim extension As String = cek.Substring(cek.IndexOf("."))
                       file_Type = getcontentType(extension) & "Content-length:" & ofile.Length & vbCrLf
                   End If
                   Dim response_200() As Byte = enc.GetBytes("HTTP/1.1 200 OK" & vbCrLf & file_Type & "server:MRI-server=" & My.Application, )
                   cln.GetStream.Write(response_200, 0, response_200.Length)

                   Dim fstream As New FileStream(ofile.FullName, FileMode.Open, FileAccess.Read)
                   Dim br As New BinaryReader(fstream)
                   Dim data() As Byte = br.readbytes(fstream.Length)
                   cln.GetStream.Write(data, 0, data.Length)

               Else
                   Dim Response_404() As Byte = enc.GetBytes("HTTP/1.1 404 NOT Found" & vbCrLf & "Refresh: s; url=/" & vbCrLf & vbCr)
                   cln.GetStream.Write(Response_404, 0, Response_404.Length)
               End If
           Loop Until cln.Connected
       Catch ex As Exception
           If cln.Connected Then cln.Close()
       End Try

       Try
           If cln.Connected Then cln.Close()
           If Not thrC(id) Is Nothing Then
               If thrC(id).IsAlive Then thrC(id).Abort()
           End If
       Catch ex As Exception
       End Try

   End Sub
   Private Shared Function getcontentType(ByVal extension As String) As String
       Dim CT As String = ""
       Try
           Select Case extension
               Case ".css"
                   CT = "text/css"
               Case ".php"
                   CT = "text/php"
               Case ".htm", ".html"
                   CT = "text/html"
               Case ".js"
                   CT = "application/x-javascript"
               Case ""
               Case ""
               Case ""
               Case ""
               Case ""

           End Select
       Catch ex As Exception

       End Try

       If CT <> " " Then
           CT = "Content-Type:" & CT & vbCrLf
       End If
       Return CT

   End Function

   Private Sub Form1_Disposed(sender As Object, e As EventArgs) Handles Me.Disposed
       End
   End Sub

   Dim strHostName As String = System.Net.Dns.GetHostName
   Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
       Try
           Me.TextBox2.Text = "127.0.0.1"
           'Me.TextBox2.Text = Dns.GetHostByName(strHostName).AddressList(0).ToString
       Catch ex As Exception
           Me.TextBox2.Text = "127.0.0.1"
       End Try
   End Sub

   Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
       If Button1.Text = "Start" Then
           Button1.Text = "Stop"
           Dim ip = New System.Net.IPEndPoint(System.Net.IPAddress.Parse(Me.TextBox2.Text), 80)
           Svr = New TcpListener(ip)
           Try
               Svr.Start()
               threadListen = New Threading.Thread(AddressOf StartListen)
               threadListen.Start()
           Catch ex As Exception


               MsgBox("Error: " & ex.Message)

           End Try
       Else
           Button1.Text = "Start"
           Try
               Svr.Stop()
           Catch ex As Exception
           End Try

           For Each t As Threading.Thread In thrC
               Try
                   If t.IsAlive Then t.Abort()

               Catch ex As Exception
               End Try
           Next
       End If
   End Sub
End Class


و ايضا وجدت هذا الكود في هذاالرابط فهل يمكن تطبيقه بنفس الفكرة
كود :
Imports System.IO
Imports System.Net
Imports System.Net.Sockets
Imports System.Text
Imports System.Threading
Imports System.Xml

Public Class WebServer
#Region "Declarations"
   Private Shared singleWebserver As WebServer
   Private Shared blnFlag As Boolean

   Private LocalTCPListener As TcpListener
   Private LocalPort As Integer = 80
   Private LocalAddress As IPAddress = GetIPAddress()
   Private DefaultDoc As String = "index.html"
   Private WebThread As Thread
   Private LocalImageDir As String
   Private LocalVirtualRoot As String
#End Region

#Region "Properties"
   Public Property ListenWebPort() As Integer
       Get
           Return LocalPort
       End Get
       Set(ByVal Value As Integer)
           LocalPort = Value
       End Set
   End Property

   Public ReadOnly Property ListenIPAddress() As IPAddress
       Get
           Return LocalAddress
       End Get
   End Property


   Public Property DefaultDocument() As String
       Get
           Return DefaultDoc
       End Get
       Set(ByVal Value As String)
           DefaultDoc = Value
       End Set
   End Property

   Public Property ImageDirectory() As String
       Get
           Return LocalImageDir
       End Get
       Set(ByVal Value As String)
           LocalImageDir = Value
       End Set
   End Property

   Public Property VirtualRoot() As String
       Get
           Return LocalVirtualRoot
       End Get
       Set(ByVal Value As String)
           LocalVirtualRoot = Value
       End Set
   End Property
#End Region

#Region "Methods"

   Private Function GetIPAddress() As IPAddress
       Dim oAddr As System.Net.IPAddress
       Dim sAddr As String
       With System.Net.Dns.GetHostByName(System.Net.Dns.GetHostName())
           If .AddressList.Length > 0 Then
               oAddr = New IPAddress(.AddressList.GetLowerBound(0))
           End If
       End With
       GetIPAddress = oAddr
   End Function


   Friend Shared Function getWebServer() As WebServer
       If Not blnFlag Then
           singleWebserver = New WebServer
           blnFlag = True
           Return singleWebserver
       Else
           Return singleWebserver
       End If
   End Function


   Public Sub StartWebServer()
       Try
           LocalTCPListener = New TcpListener(LocalAddress, LocalPort)
           LocalTCPListener.Start()
           WebThread = New Thread(AddressOf StartListen)
           WebThread.Start()
       Catch ex As Exception
           Console.WriteLine(ex.Message)
       End Try
   End Sub
'Here is where we check our XML file and see what MIME types are defined and handle the accordingly.

   Public Function GetMimeType(ByVal sRequestFile As String) As String
       Dim sr As StreamReader
       Dim sLine As String = ""
       Dim sMimeType As String = ""
       Dim sFileExt As String = ""
       Dim sMimeExt As String = ""
       sRequestFile = sRequestFile.ToLower
       Dim iStartPos As Integer = sRequestFile.IndexOf(".") + 1
       sFileExt = sRequestFile.Substring(iStartPos)
       'now go through the mime definitions and apply to the request.
       Dim dom As New XmlDocument
       dom.Load(Application.StartupPath & "\Settings.xml")
       Dim objCurrentNode As XmlNode
       objCurrentNode = dom.SelectSingleNode("//mimetypes")
       'now go through all child nodes.
       If objCurrentNode.HasChildNodes Then
           'loop
           Dim xmlMimeType As XmlNode
           For Each xmlMimeType In objCurrentNode
               sMimeExt = xmlMimeType.Name
               sMimeType = xmlMimeType.InnerText
               If (sMimeExt = sFileExt) Then
                   Exit For
               End If
           Next
       End If
       If sMimeExt = sFileExt Then
           Return sMimeType
       Else
           Return ""
       End If
   End Function

   Public Function GetTheDefaultFileName(ByVal sLocalDirectory As String) As String
       Return "index.html"
   End Function

   Public Function GetLocalPath(ByVal sWebServerRoot As String, ByVal sDirName As String) As String
       'Dim sr As StreamReader
       'Dim sLine As String = ""
       Dim sVirtualDir As String = ""
       Dim sRealDir As String = ""
       Dim iStartPos As Integer = 0
       sDirName.Trim()
       sWebServerRoot = sWebServerRoot.ToLower
       sDirName = sDirName.ToLower
       Select Case sDirName
           Case "/"
               sRealDir = LocalVirtualRoot
           Case Else
               If Mid$(sDirName, 1, 1) = "/" Then
                   sDirName = Mid$(sDirName, 2, Len(sDirName))
               End If
               sRealDir = LocalVirtualRoot & sDirName.Replace("/", "\")
       End Select
       Return sRealDir
   End Function

   Public Sub SendHeader(ByVal sHttpVersion As String, ByVal sMimeHeader As String, _
             ByVal iTotalBytes As Integer, ByVal sStatusCode As String, ByRef thisSocket As Socket)
       Dim sBuffer As String = ""
       If Len(sMimeHeader) = 0 Then
           sMimeHeader = "text/html"
       End If
       sBuffer = sHttpVersion & sStatusCode & vbCrLf & _
           "Server: X10CamControl" & vbCrLf & _
           "Content-Type: " & sMimeHeader & vbCrLf & _
           "Accept-Ranges: bytes" & vbCrLf & _
           "Content-Length: " & iTotalBytes & vbCrLf & vbCrLf

       Dim bSendData As [Byte]() = Encoding.ASCII.GetBytes(sBuffer)
       SendToBrowser(bSendData, thisSocket)
   End Sub

   Public Overloads Sub SendToBrowser(ByVal sData As String, ByRef thisSocket As Socket)
       SendToBrowser(Encoding.ASCII.GetBytes(sData), thisSocket)
   End Sub

   Public Overloads Sub SendToBrowser(ByVal bSendData As [Byte](), ByRef thisSocket As Socket)
       Dim iNumBytes As Integer = 0
       If thisSocket.Connected Then
           If (iNumBytes = thisSocket.Send(bSendData, bSendData.Length, 0)) = -1 Then
               'socket error can't send packet
           Else
               'number of bytes sent.
           End If
       Else
           'connection dropped.
       End If
   End Sub

   Private Sub New()
       'create a singleton
   End Sub

   Private Sub StartListen()
       Dim iStartPos As Integer
       Dim sRequest As String
       Dim sDirName As String
       Dim sRequestedFile As String
       Dim sErrorMessage As String
       Dim sLocalDir As String
       Dim sWebserverRoot = LocalVirtualRoot
       Dim sQueryString As String
       Dim sPhysicalFilePath As String = ""
       Dim sFormattedMessage As String = ""
       Do While True
           'accept new socket connection
           Dim mySocket As Socket = LocalTCPListener.AcceptSocket
           If mySocket.Connected Then
               Dim bReceive() As Byte = New [Byte](1024) {}
               Dim i As Integer = mySocket.Receive(bReceive, bReceive.Length, 0)
               Dim sBuffer As String = Encoding.ASCII.GetString(bReceive)
               'find the GET request.
               If (sBuffer.Substring(0, 3) <> "GET") Then
                   mySocket.Close()
                   Return
               End If
               iStartPos = sBuffer.IndexOf("HTTP", 1)
               Dim sHttpVersion = sBuffer.Substring(iStartPos, 8)
               sRequest = sBuffer.Substring(0, iStartPos - 1)
               sRequest.Replace("\\", "/")
               If (sRequest.IndexOf(".") < 1) And (Not (sRequest.EndsWith("/"))) Then
                   sRequest = sRequest & "/"
               End If
               'get the file name
               iStartPos = sRequest.LastIndexOf("/") + 1
               sRequestedFile = sRequest.Substring(iStartPos)
               If InStr(sRequest, "?") <> 0 Then
                   iStartPos = sRequest.IndexOf("?") + 1
                   sQueryString = sRequest.Substring(iStartPos)
                   sRequestedFile = Replace(sRequestedFile, "?" & sQueryString, "")
               End If
               'get the directory
               sDirName = sRequest.Substring(sRequest.IndexOf("/"), sRequest.LastIndexOf("/") - 3)
               'identify the physical directory.
               If (sDirName = "/") Then
                   sLocalDir = sWebserverRoot
               Else
                   sLocalDir = GetLocalPath(sWebserverRoot, sDirName)
               End If
               'if the directory isn't there then display error.
               If sLocalDir.Length = 0 Then
                   sErrorMessage = "Error!! Requested Directory does not exists"
                   SendHeader(sHttpVersion, "", sErrorMessage.Length, " 404 Not Found", mySocket)
                   SendToBrowser(sErrorMessage, mySocket)
                   mySocket.Close()
               End If

               If sRequestedFile.Length = 0 Then
                   sRequestedFile = GetTheDefaultFileName(sLocalDir)
                   If sRequestedFile = "" Then
                       sErrorMessage = "Error!! No Default File Name Specified"
                       SendHeader(sHttpVersion, "", sErrorMessage.Length, " 404 Not Found", mySocket)
                       SendToBrowser(sErrorMessage, mySocket)
                       mySocket.Close()
                       Return
                   End If
               End If

               Dim sMimeType As String = GetMimeType(sRequestedFile)
               sPhysicalFilePath = sLocalDir & sRequestedFile
               If Not File.Exists(sPhysicalFilePath) Then
                   sErrorMessage = "404 Error! File Does Not Exists..."
                   SendHeader(sHttpVersion, "", sErrorMessage.Length, " 404 Not Found", mySocket)
                   SendToBrowser(sErrorMessage, mySocket)
               Else

                   Try
                       Dim iTotBytes As Integer = 0
                       Dim sResponse As String = ""
                       Dim fs As New FileStream(sPhysicalFilePath, FileMode.Open, FileAccess.Read, FileShare.Read)
                       Dim reader As New BinaryReader(fs)
                       Dim bytes() As Byte = New Byte(fs.Length) {}

                       While reader.BaseStream.Position < reader.BaseStream.Length
                           reader.Read(bytes, 0, bytes.Length)
                           sResponse = sResponse & Encoding.ASCII.GetString(bytes, 0, reader.BaseStream.Length)
                           iTotBytes = reader.BaseStream.Length
                       End While
                       reader.Close()
                       fs.Close()
                       SendHeader(sHttpVersion, sMimeType, iTotBytes, " 200 OK", mySocket)
                       SendToBrowser(bytes, mySocket)
                   Catch ex As Exception
                       sErrorMessage = "404 Error! File Does Not Exists..."
                       SendHeader(sHttpVersion, "", sErrorMessage.Length, " 404 Not Found", mySocket)
                       SendToBrowser(sErrorMessage, mySocket)
                   End Try

               End If
               mySocket.Close()

           End If
       Loop

   End Sub

   Public Sub StopWebServer()
       Try
           LocalTCPListener.Stop()
           WebThread.Abort()
       Catch ex As Exception
           Console.WriteLine(ex.Message)
       End Try
   End Sub
#End Region


End Class
الرد
تم الشكر بواسطة: zinom
#2
أنصحك أن تتصل بالشخص الذي كتب الكود إما أن ترسل له إيميل او تترك له كومنت في اليوتوب و انتا و حظك بقي
الرد
تم الشكر بواسطة: bidaya , zinom
#3
(02-05-17, 10:58 AM)silverlight كتب : أنصحك أن تتصل بالشخص الذي كتب الكود إما أن ترسل له إيميل او تترك له كومنت في اليوتوب و انتا و حظك بقي

شكرا لك اخي الكريم
الرد
تم الشكر بواسطة:
#4
1-التعديل

كود :
                   Dim response_200() As Byte = enc.GetBytes("HTTP/1.1 200 OK" & vbCrLf & file_Type & "server:MRI-server=" & Application.StartupPath & "\HomePage\index.html")

- وممكن باردو تستبدل دي (
كود :
\index.html"
بالمتغير النصي cek عشان يبقي الكود زي ما صاحب الفديو عامله
كود :
& cek


كود :
                   Dim response_200() As Byte = enc.GetBytes("HTTP/1.1 200 OK" & vbCrLf & file_Type & "server:MRI-server=" & Application.StartupPath & "\HomePage" & cek)

2- المفروض انو موجود فولدر اسمه (HomePage) في مسار الملف التنفيذي للمشروع بتاعك
زي الكود ده ما بيقول

   

3-جواه صفحة رئيسيه (index.html-3)
   
مرتبطه بعدة صفح تانيه زي صفحة الفديو الي ظاهر الي المفروض اسمها (Video_Test_Body.html)
طبعا ده زي ما هوا ظاهر في الفديو
   
جرب التعديل وقولي النتيجه
اللهم صلي علي نبي (الرحمه) محمد رسول الله وبارك علي اله وصحابته والتابعين  واحقن دماء امتنا واجعل بأسنا علي اعدائنا يا ارحم الراحمين
[b]امين [/b]



الرد
تم الشكر بواسطة:
#5
(02-05-17, 05:06 PM)zinom كتب :
1-التعديل

كود :
                   Dim response_200() As Byte = enc.GetBytes("HTTP/1.1 200 OK" & vbCrLf & file_Type & "server:MRI-server=" & Application.StartupPath & "\HomePage\index.html")

- وممكن باردو تستبدل دي (
كود :
\index.html"
بالمتغير النصي cek عشان يبقي الكود زي ما صاحب الفديو عامله
كود :
& cek


كود :
                   Dim response_200() As Byte = enc.GetBytes("HTTP/1.1 200 OK" & vbCrLf & file_Type & "server:MRI-server=" & Application.StartupPath & "\HomePage" & cek)

2- المفروض انو موجود فولدر اسمه (HomePage) في مسار الملف التنفيذي للمشروع بتاعك
زي الكود ده ما بيقول



3-جواه صفحة رئيسيه (index.html-3)
مرتبطه بعدة صفح تانيه زي صفحة الفديو الي ظاهر الي المفروض اسمها (Video_Test_Body.html)
طبعا ده زي ما هوا ظاهر في الفديو

جرب التعديل وقولي النتيجه

لم ينجح اخي الكريم وقد ارفقت لك  المشروع  احسن لترى بنفسك


الملفات المرفقة
.rar   HTTP Server.rar (الحجم : 242.47 ك ب / التحميلات : 41)
الرد
تم الشكر بواسطة:
#6
   
إن شاء الله
باقي حاجه بسيطه وارفعلك المشروع
اللهم صلي علي نبي (الرحمه) محمد رسول الله وبارك علي اله وصحابته والتابعين  واحقن دماء امتنا واجعل بأسنا علي اعدائنا يا ارحم الراحمين
[b]امين [/b]



الرد
تم الشكر بواسطة: bidaya , bidaya
#7

الموضوع ممتاز وفكرته كويسه

اتمني من المشرفين الكرام نقله لقسم الامثله

اتفضل المشروع بعد التعديل


الملفات المرفقة
.rar   HTTP Server-RE-edite by zinom.rar (الحجم : 780.38 ك ب / التحميلات : 58)
اللهم صلي علي نبي (الرحمه) محمد رسول الله وبارك علي اله وصحابته والتابعين  واحقن دماء امتنا واجعل بأسنا علي اعدائنا يا ارحم الراحمين
[b]امين [/b]



الرد
تم الشكر بواسطة: bidaya , bidaya
#8
الف شكر اخي الكريم عمل جد ممتاز
النموذج شغال بامتياز
الرد
تم الشكر بواسطة:


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
  [VB.NET] مساعدة في تحويل هذا الكود و جعله يعمل Necro PC 2 129 15-10-21, 03:08 PM
آخر رد: Necro PC
  مساعدة في كود حذف ahmedbezia 1 203 13-10-21, 02:05 PM
آخر رد: Miloud
  [سؤال] ما هو الخطأ في عدم تنفيذ هذه الكود محمد الصدفاوي 6 393 09-10-21, 10:05 PM
آخر رد: محمد الصدفاوي
  [سؤال] ممكن عمل الكود فجول بيسك بنفس الطريقة بسام محمدغانم 0 138 07-10-21, 09:12 AM
آخر رد: بسام محمدغانم
  [VB.NET] مساعدة من اهل الاختصاص نضال ابو العافية 0 123 04-10-21, 12:47 AM
آخر رد: نضال ابو العافية
  ممكن مساعدة بخصوص كويري معين حدتت به اخطاء Alanwalker 8 730 02-10-21, 01:52 PM
آخر رد: mahmoud_f
  محتاج كود التنقبل بين الاسطر التالي والسابق في TextBox shady2020 1 701 22-09-21, 11:10 AM
آخر رد: Kareem2021
  محتاج مساعدة ضرورية معاذ السامرائي 2 360 22-09-21, 12:08 AM
آخر رد: معاذ السامرائي
  [VB.NET] مساعدة في تعديل كود ميدو الفنان 1 273 20-09-21, 10:57 PM
آخر رد: ميدو الفنان
  مساعدة في views sql cordava 4 290 19-09-21, 12:19 AM
آخر رد: cordava

التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم