Arkadaşlar bu projede sizlere HTTP server nasıl yapılır? kolay bir şekilde öğreteceğim.(size kolay gelecek şekilde...).Okuma alışkanlığı olmayanlar bu konudan derhal ayrılsınlar.Tamamını okumak yararınızadır....!
Önce http server nedir?
-HTTP Server adını sıkça duyduğumuz iis,apache,wamp,baby asp... gibi bilgisayarımıza port açan,bize sayfalarımızı deneme imkanı sunan yazılımlardır.
-Bazı arkadaşlarımızın windows cd si olmayabilir.Dolayısıyla iis kuramazlar.Diğerlerinide Linux bilgisi eksikliğinden kurmak onlara zor gelebilir.İndex hazırlarlar ancak bunu bir sunucuda deneyemezler.
-İşte size bir fırsat artık kendi serveriniz da indexinizi deneyin
-Ancak HTML tabanlı bir yazılımdır.Tabi geliştirmek isteyen asp,php tanımlarını ekleyebilir.
-Gif ve jpeg destekler.Şimdilik asp ve php yi metin olarak gösteriyor.
---------------------------------------------------------------------------------------------------------
-Hiçbir ayar,kod yazımı yapmayacaksınız.Sadece söyleyeceğim yerlere kopyala yapıştır yapın.
-Tabi "KES-MEZAR" yazan kısımları programı inceledikten sonra kendi adınızla değiştirmek size kalmış...
-Port numarasını istediğiniz gibi değiştirebilirsiniz.Ben 9999 yaptım...
-Önce kendinize bir dizin seçin yada var olan C:\Inetpub\wwwroot\ dizinini kullanın."index.html(.htm)"niz
bu klasörde olsun.(yada sizin istediğiniz.ancak aşağıdaki 'BURAYA İSTEDİĞİNİZ DİZİN ADINI YAZIN...
dediğim yere hangi dizini seçtiyseniz onu yazın.
-Şimdi VB6 yı açınız,bir adet standart exe projesi oluşturun.
-Forma bir adet label ve bir adet timer ekleyin.
-Project/Bileşenler(components)'ten Microsoft Winsock Control 6.0 sp4(hangisi varsa) forma ekleyin.
-Masa üstüne boş bir klasör oluşturun.Projeyi farklı kaydetten oluşturduğunuz klasöre kaydedin.
-Visual basic ten çıkın.Şimdi o klasöre girin.
-3 tane dosya var gördünüz mü?Form1.frm(pencere resmi olan)'ı not defteri ile açın.
-İçinde ne varsa silin ve aşağıdakileri yapıştırın ve kaydedin.
----------------------------------------------------------------
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCN.OCX"
Begin VB.Form frmMain
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "KES-MEZAR HTTP SERVER"
ClientHeight = 5355
ClientLeft = 60
ClientTop = 345
ClientWidth = 3645
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5355
ScaleWidth = 3645
StartUpPosition = 2 'CenterScreen
Begin VB.Timer tmrSendData
Index = 0
Left = 3120
Top = 120
End
Begin MSWinsockLib.Winsock Sck
Index = 0
Left = 2640
Top = 120
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Label lblFileProgress
AutoSize = -1 'True
Caption = "(Dinleniyor)"
Height = 195
Index = 0
Left = 90
TabIndex = 0
Top = 0
Width = 780
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const ServerName As String = "HTTP Server Version 1.0.0"
'
Private Const PathShared As String = "C:\Inetpub\wwwroot\" 'BURAYA İSTEDİĞİNİZ DİZİN ADINI YAZIN...
Private Type ConnectionInfo
FileNum As Integer
TotalLength As Long
TotalSent As Long
FileName As String
DataStr As String
End Type
Private CInfo() As ConnectionInfo
Private Sub Form_Load()
Sck(0).LocalPort = 9999
Sck(0).Listen
DoEvents
If Sck(0).State = sckListening Then lblFileProgress(0).Caption = "01. Dinliyorum"
End Sub
Private Sub Sck_Close(Index As Integer)
tmrSendData(Index).Enabled = False
Do
Sck(Index).Close
DoEvents
Loop Until Sck(Index).State = sckClosed
CInfo(Index).FileNum = 0
CInfo(Index).FileName = ""
CInfo(Index).TotalLength = 0
CInfo(Index).TotalSent = 0
lblFileProgress(Index).Caption = Right("00" & Index, 2) & " Kapatıyorum.."
End Sub
Private Sub Sck_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Dim K As Integer
For K = 1 To Sck.UBound
If Sck(K).State = sckClosed Then Exit For
Next K
If K > Sck.UBound Then
K = Sck.UBound + 1
Load Sck(K)
Load lblFileProgress(K)
lblFileProgress(K).Top = (lblFileProgress(0).Height + 5) * K
lblFileProgress(K).Visible = True
ReDim Preserve CInfo(K)
Load tmrSendData(K)
tmrSendData(K).Enabled = False
tmrSendData(K).Interval = 1
End If
CInfo(K).FileName = ""
CInfo(0).FileNum = 0
CInfo(K).TotalLength = 0
CInfo(K).TotalSent = 0
Sck(K).Accept requestID
End Sub
Private Sub Sck_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim rData As String, sHeader As String, RequestedFile As String, ContentType As String
Dim CompletePath As String
Sck(Index).GetData rData, vbString
If rData Like "GET * HTTP/1.?*" Then
RequestedFile = LeftRange(rData, "GET ", " HTTP/1.", , ReturnEmptyStr)
If InStr(1, RequestedFile, "/../") > 0 Or InStr(1, RequestedFile, "/./") > 0 Or _
InStr(1, RequestedFile, "*") > 0 Or InStr(1, RequestedFile, "?") > 0 Or RequestedFile = "" Then
sHeader = "HTTP/1.0 404 Not Found" & vbNewLine & "Server: " & ServerName & vbNewLine & vbNewLine
CInfo(Index).TotalLength = Len(sHeader)
Sck(Index).SendData sHeader
Else
CompletePath = Replace(PathShared & Replace(RequestedFile, "/", "\"), "\\", "\")
CompletePath = Replace(CompletePath, "%20", " ")
Debug.Print CompletePath
If Dir(CompletePath, vbArchive + vbReadOnly + vbDirectory) <> "" Then
If (GetAttr(CompletePath) And vbDirectory) = vbDirectory Then
CInfo(Index).DataStr = BuildHTMLDirList(PathShared, RequestedFile)
CInfo(Index).FileNum = -1
sHeader = "HTTP/1.0 200 OK" & vbNewLine & _
"Server: " & ServerName & vbNewLine & _
"Content-Type: text/html" & vbNewLine & _
"Content-Length: " & Len(CInfo(Index).DataStr) & vbNewLine & _
vbNewLine
CInfo(Index).TotalLength = Len(sHeader) + Len(CInfo(Index).DataStr)
Else
lblFileProgress(Index).Caption = Right("00" & Index, 2) & " Transfering: " & RequestedFile
CInfo(Index).FileName = RequestedFile
CInfo(Index).FileNum = FreeFile
Open CompletePath For Binary Access Read As CInfo(Index).FileNum
Select Case LCase(LeftRight(RequestedFile, ".", , ReturnEmptyStr))
Case "jpg", "jpeg"
ContentType = "Content-Type: image/jpeg"
Case "gif"
ContentType = "Content-Type: image/gif"
Case "htm", "html"
ContentType = "Content-Type: text/html"
Case "zip"
ContentType = "Content-Type: application/zip"
Case "mp3"
ContentType = "Content-Type: audio/mpeg"
Case "m3u", "pls", "xpl"
ContentType = "Content-Type: audio/x-mpegurl"
Case Else
ContentType = "Content-Type: */*"
End Select
sHeader = "HTTP/1.0 200 OK" & vbNewLine & _
"Server: " & ServerName & vbNewLine & _
ContentType & vbNewLine & _
"Content-Length: " & LOF(CInfo(Index).FileNum) & vbNewLine & _
vbNewLine
CInfo(Index).TotalLength = Len(sHeader) + LOF(CInfo(Index).FileNum)
End If
Sck(Index).SendData sHeader
Else
sHeader = "HTTP/1.0 404 Not Found" & vbNewLine & "Server: " & ServerName & vbNewLine & vbNewLine
CInfo(Index).TotalLength = Len(sHeader)
Sck(Index).SendData sHeader
End If
End If
Else
sHeader = "HTTP/1.0 501 Not Implemented" & vbNewLine & "Server: " & ServerName & vbNewLine & vbNewLine
CInfo(Index).TotalLength = Len(sHeader)
Sck(Index).SendData sHeader
End If
End Sub
Private Function BuildHTMLDirList(ByVal Root As String, ByVal DirToList As String)
Dim Dirs As New Collection, Files As New Collection
Dim sDir As String, Path As String, HTML As String, K As Long
Root = Replace(Root, "/", "\")
DirToList = Replace(DirToList, "/", "\")
If Right(Root, 1) <> "\" Then Root = Root & "\"
If Left(DirToList, 1) = "\" Then DirToList = Mid(DirToList, 2)
If Right(DirToList, 1) <> "\" Then DirToList = DirToList & "\"
DirToList = Replace(DirToList, "%20", " ")
sDir = Dir(Replace(Root & DirToList, "\\", "\") & "*.*", vbArchive + vbDirectory + vbReadOnly)
Do Until Len(sDir) = 0
If sDir <> ".." And sDir <> "." Then
Path = Replace(Root & DirToList, "\\", "\") & sDir
If (GetAttr(Path) And vbDirectory) = vbDirectory Then
Dirs.Add sDir
Else
Files.Add sDir
End If
End If
sDir = Dir
Loop
HTML = "<html><body>"
If Dirs.Count > 0 Then
HTML = HTML & "<b>Directories:</b><br>"
For K = 1 To Dirs.Count
HTML = HTML & "<a href=""" & _
Replace(Replace("/" & DirToList & Dirs(K), "\", "/"), "//", "/") & """>" & _
Dirs(K) & "</a><br>" & vbNewLine
Next K
End If
If Files.Count > 0 Then
HTML = HTML & "<br><b>Files:</b><br><table width=""100%"" border=""1"" cellpadding=""3"" cellspacing=""2"">" & vbNewLine
For K = 1 To Files.Count
HTML = HTML & "<tr>" & vbNewLine
HTML = HTML & "<td width=""100%""><a href=""" & _
Replace(Replace("/" & DirToList & Files(K), "\", "/"), "//", "/") & """>" & _
Files(K) & "</a></td>" & vbNewLine
HTML = HTML & "<td nowrap>" & _
Format(FileLen(Replace(Root & DirToList, "\\", "\") & Files(K)) / 1024#, "###,###,###,##0") & _
" KBytes</td>" & vbNewLine
HTML = HTML & "</tr>" & vbNewLine
Next K
HTML = HTML & "</table>" & vbNewLine
End If
If Dirs.Count = 0 And Files.Count = 0 Then
HTML = HTML & "This folder is empty."
End If
BuildHTMLDirList = HTML & "</body></html>"
End Function
Private Sub Sck_SendComplete(Index As Integer)
If CInfo(Index).TotalSent >= CInfo(Index).TotalLength Then
Sck_Close Index
Else
tmrSendData(Index).Interval = 1
tmrSendData(Index).Enabled = True
End If
End Sub
Private Sub Sck_SendProgress(Index As Integer, ByVal bytesSent As Long, ByVal bytesRemaining As Long)
CInfo(Index).TotalSent = CInfo(Index).TotalSent + bytesSent
If CInfo(Index).FileNum > 0 Then
On Error Resume Next
lblFileProgress(Index).Caption = Right("00" & Index, 2) & " Transfering: " & CInfo(Index).FileName & " - " & _
CInfo(Index).TotalSent & " of " & LOF(CInfo(Index).FileNum) & " bytes sent, " & _
Format(CInfo(Index).TotalSent / LOF(CInfo(Index).FileNum) * 100#, "00.00") & " %Done."
If Err.Number <> 0 Then Err.Clear
End If
End Sub
Private Sub tmrSendData_Timer(Index As Integer)
On Error Resume Next
Const BufferLength As Long = 1024 * 2
Dim Buffer As String
If CInfo(Index).FileNum = -1 Then
Buffer = Left(CInfo(Index).DataStr, BufferLength)
CInfo(Index).DataStr = Mid(CInfo(Index).DataStr, BufferLength + 1)
Sck(Index).SendData Buffer
If Len(CInfo(Index).DataStr) = 0 Then CInfo(Index).FileNum = 0
ElseIf CInfo(Index).FileNum > 0 Then
If Loc(CInfo(Index).FileNum) + BufferLength > LOF(CInfo(Index).FileNum) Then
Buffer = String(LOF(CInfo(Index).FileNum) - Loc(CInfo(Index).FileNum), 0)
Else
Buffer = String(BufferLength, 0)
End If
Get CInfo(Index).FileNum, , Buffer
Sck(Index).SendData Buffer
If Loc(CInfo(Index).FileNum) >= LOF(CInfo(Index).FileNum) Then
Close CInfo(Index).FileNum
CInfo(Index).FileNum = 0
End If
End If
tmrSendData(Index).Enabled = False
End Sub
---------------------------------------------------------------------
-Şimdi project1.vbp dosyasına çift tıklayın.Visual basic açılsın.
-Yukarda Project'i tıklayın Modül ekle diyin(üstten 3.)
-Açılan modüle sayfasına da aşağıdaki kodları yapıştırın.
---------------------------------------------------------------------
Option Explicit
Public Enum IfStringNotFound
ReturnOriginalStr = 0
ReturnEmptyStr = 1
End Enum
Public Function RightLeft(ByRef Str As String, RFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStrRev(Str, RFind, , Compare)
If K = 0 Then
RightLeft = IIf(RetError = ReturnOriginalStr, Str, "")
Else
RightLeft = Left(Str, K - 1)
End If
End Function
Public Function RightRight(ByRef Str As String, RFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStrRev(Str, RFind, , Compare)
If K = 0 Then
RightRight = IIf(RetError = ReturnOriginalStr, Str, "")
Else
RightRight = Mid(Str, K + 1, Len(Str))
End If
End Function
Public Function LeftLeft(ByRef Str As String, LFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStr(1, Str, LFind, Compare)
If K = 0 Then
LeftLeft = IIf(RetError = ReturnOriginalStr, Str, "")
Else
LeftLeft = Left(Str, K - 1)
End If
End Function
Public Function LeftRight(ByRef Str As String, LFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStr(1, Str, LFind, Compare)
If K = 0 Then
LeftRight = IIf(RetError = ReturnOriginalStr, Str, "")
Else
LeftRight = Right(Str, (Len(Str) - Len(LFind)) - K + 1)
End If
End Function
Public Function LeftRange(ByRef Str As String, StrFrom As String, StrTo As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long, Q As Long
K = InStr(1, Str, StrFrom, Compare)
If K > 0 Then
Q = InStr(K + Len(StrFrom), Str, StrTo, Compare)
If Q > K Then
LeftRange = Mid(Str, K + Len(StrFrom), (Q - K) - Len(StrFrom))
Else
LeftRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
Else
LeftRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
End Function
Public Function RightRange(ByRef Str As String, StrFrom As String, StrTo As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long, Q As Long
K = InStrRev(Str, StrTo, , Compare)
If K > 0 Then
Q = InStrRev(Str, StrFrom, K, Compare)
If Q > 0 Then
RightRange = Mid(Str, Q + Len(StrFrom), (K - Q) - Len(StrTo))
Else
RightRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
Else
RightRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
End Function
Public Function SOUNDEX(Word As String) As String
Dim K As Integer, PrevNum As Integer, Num As Integer, LLetter As String
Dim SoundX As String
For K = 2 To Len(Word)
LLetter = LCase(Mid$(Word, K, 1))
Select Case LLetter
Case "b", "f", "p", "v"
Num = 1
Case "c", "e", "g", "j", "k", "q", "s", "x", "z"
Num = 2
Case "d", "t"
Num = 3
Case "l"
Num = 4
Case "m", "n"
Num = 5
Case "r"
Num = 6
Case "a", "e", "i", "o", "u"
Num = 7
End Select
If PrevNum <> Num Then
PrevNum = Num
SoundX = SoundX & Num
End If
Next K
SoundX = Replace(SoundX, "7", "", , , vbBinaryCompare)
SOUNDEX = UCase(Left(Word, 1)) & Left(SoundX & "000", 3)
End Function
Public Function SOUNDEX2(Word As String, Optional StrLength As Integer = 8) As String
Dim K As Integer, PrevNum As Integer, Num As Integer, LLetter As String
Dim SoundX As String
For K = 2 To Len(Word)
LLetter = LCase(Mid(Word, K, 1))
Select Case LLetter
Case "b", "f", "p", "v"
Num = 1
Case "c", "e", "g", "j", "k", "q", "s", "x", "z"
Num = 2
Case "d", "t"
Num = 3
Case "l"
Num = 4
Case "m", "n"
Num = 5
Case "r"
Num = 6
Case "a", "e", "i", "o", "u"
Num = 7
End Select
If PrevNum <> Num Then
PrevNum = Num
SoundX = SoundX & Num
End If
Next K
SoundX = Replace(SoundX, "7", "", , , vbBinaryCompare)
SOUNDEX2 = UCase(Left(Word, 1)) & Left(SoundX & String(StrLength - 1, "0"), StrLength - 1)
End Function
--------------------------------------------------------------------------
-Evet şimdi programı çalıştırın.En sevdiğiniz tarayıcıyı açın localhost:9999 yazıp enter a basın.
-Çalışıyor değil mi?Şimdi ister düzenleyin ister direk derleyip kaydedin.
-Hiç kod yazmadan bir program daha yazdığınız için kendinize SAYGI DUYUN....
Önce http server nedir?
-HTTP Server adını sıkça duyduğumuz iis,apache,wamp,baby asp... gibi bilgisayarımıza port açan,bize sayfalarımızı deneme imkanı sunan yazılımlardır.
-Bazı arkadaşlarımızın windows cd si olmayabilir.Dolayısıyla iis kuramazlar.Diğerlerinide Linux bilgisi eksikliğinden kurmak onlara zor gelebilir.İndex hazırlarlar ancak bunu bir sunucuda deneyemezler.
-İşte size bir fırsat artık kendi serveriniz da indexinizi deneyin
-Ancak HTML tabanlı bir yazılımdır.Tabi geliştirmek isteyen asp,php tanımlarını ekleyebilir.
-Gif ve jpeg destekler.Şimdilik asp ve php yi metin olarak gösteriyor.
---------------------------------------------------------------------------------------------------------
-Hiçbir ayar,kod yazımı yapmayacaksınız.Sadece söyleyeceğim yerlere kopyala yapıştır yapın.
-Tabi "KES-MEZAR" yazan kısımları programı inceledikten sonra kendi adınızla değiştirmek size kalmış...
-Port numarasını istediğiniz gibi değiştirebilirsiniz.Ben 9999 yaptım...
-Önce kendinize bir dizin seçin yada var olan C:\Inetpub\wwwroot\ dizinini kullanın."index.html(.htm)"niz
bu klasörde olsun.(yada sizin istediğiniz.ancak aşağıdaki 'BURAYA İSTEDİĞİNİZ DİZİN ADINI YAZIN...
dediğim yere hangi dizini seçtiyseniz onu yazın.
-Şimdi VB6 yı açınız,bir adet standart exe projesi oluşturun.
-Forma bir adet label ve bir adet timer ekleyin.
-Project/Bileşenler(components)'ten Microsoft Winsock Control 6.0 sp4(hangisi varsa) forma ekleyin.
-Masa üstüne boş bir klasör oluşturun.Projeyi farklı kaydetten oluşturduğunuz klasöre kaydedin.
-Visual basic ten çıkın.Şimdi o klasöre girin.
-3 tane dosya var gördünüz mü?Form1.frm(pencere resmi olan)'ı not defteri ile açın.
-İçinde ne varsa silin ve aşağıdakileri yapıştırın ve kaydedin.
----------------------------------------------------------------
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCN.OCX"
Begin VB.Form frmMain
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "KES-MEZAR HTTP SERVER"
ClientHeight = 5355
ClientLeft = 60
ClientTop = 345
ClientWidth = 3645
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5355
ScaleWidth = 3645
StartUpPosition = 2 'CenterScreen
Begin VB.Timer tmrSendData
Index = 0
Left = 3120
Top = 120
End
Begin MSWinsockLib.Winsock Sck
Index = 0
Left = 2640
Top = 120
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Label lblFileProgress
AutoSize = -1 'True
Caption = "(Dinleniyor)"
Height = 195
Index = 0
Left = 90
TabIndex = 0
Top = 0
Width = 780
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const ServerName As String = "HTTP Server Version 1.0.0"
'
Private Const PathShared As String = "C:\Inetpub\wwwroot\" 'BURAYA İSTEDİĞİNİZ DİZİN ADINI YAZIN...
Private Type ConnectionInfo
FileNum As Integer
TotalLength As Long
TotalSent As Long
FileName As String
DataStr As String
End Type
Private CInfo() As ConnectionInfo
Private Sub Form_Load()
Sck(0).LocalPort = 9999
Sck(0).Listen
DoEvents
If Sck(0).State = sckListening Then lblFileProgress(0).Caption = "01. Dinliyorum"
End Sub
Private Sub Sck_Close(Index As Integer)
tmrSendData(Index).Enabled = False
Do
Sck(Index).Close
DoEvents
Loop Until Sck(Index).State = sckClosed
CInfo(Index).FileNum = 0
CInfo(Index).FileName = ""
CInfo(Index).TotalLength = 0
CInfo(Index).TotalSent = 0
lblFileProgress(Index).Caption = Right("00" & Index, 2) & " Kapatıyorum.."
End Sub
Private Sub Sck_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Dim K As Integer
For K = 1 To Sck.UBound
If Sck(K).State = sckClosed Then Exit For
Next K
If K > Sck.UBound Then
K = Sck.UBound + 1
Load Sck(K)
Load lblFileProgress(K)
lblFileProgress(K).Top = (lblFileProgress(0).Height + 5) * K
lblFileProgress(K).Visible = True
ReDim Preserve CInfo(K)
Load tmrSendData(K)
tmrSendData(K).Enabled = False
tmrSendData(K).Interval = 1
End If
CInfo(K).FileName = ""
CInfo(0).FileNum = 0
CInfo(K).TotalLength = 0
CInfo(K).TotalSent = 0
Sck(K).Accept requestID
End Sub
Private Sub Sck_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim rData As String, sHeader As String, RequestedFile As String, ContentType As String
Dim CompletePath As String
Sck(Index).GetData rData, vbString
If rData Like "GET * HTTP/1.?*" Then
RequestedFile = LeftRange(rData, "GET ", " HTTP/1.", , ReturnEmptyStr)
If InStr(1, RequestedFile, "/../") > 0 Or InStr(1, RequestedFile, "/./") > 0 Or _
InStr(1, RequestedFile, "*") > 0 Or InStr(1, RequestedFile, "?") > 0 Or RequestedFile = "" Then
sHeader = "HTTP/1.0 404 Not Found" & vbNewLine & "Server: " & ServerName & vbNewLine & vbNewLine
CInfo(Index).TotalLength = Len(sHeader)
Sck(Index).SendData sHeader
Else
CompletePath = Replace(PathShared & Replace(RequestedFile, "/", "\"), "\\", "\")
CompletePath = Replace(CompletePath, "%20", " ")
Debug.Print CompletePath
If Dir(CompletePath, vbArchive + vbReadOnly + vbDirectory) <> "" Then
If (GetAttr(CompletePath) And vbDirectory) = vbDirectory Then
CInfo(Index).DataStr = BuildHTMLDirList(PathShared, RequestedFile)
CInfo(Index).FileNum = -1
sHeader = "HTTP/1.0 200 OK" & vbNewLine & _
"Server: " & ServerName & vbNewLine & _
"Content-Type: text/html" & vbNewLine & _
"Content-Length: " & Len(CInfo(Index).DataStr) & vbNewLine & _
vbNewLine
CInfo(Index).TotalLength = Len(sHeader) + Len(CInfo(Index).DataStr)
Else
lblFileProgress(Index).Caption = Right("00" & Index, 2) & " Transfering: " & RequestedFile
CInfo(Index).FileName = RequestedFile
CInfo(Index).FileNum = FreeFile
Open CompletePath For Binary Access Read As CInfo(Index).FileNum
Select Case LCase(LeftRight(RequestedFile, ".", , ReturnEmptyStr))
Case "jpg", "jpeg"
ContentType = "Content-Type: image/jpeg"
Case "gif"
ContentType = "Content-Type: image/gif"
Case "htm", "html"
ContentType = "Content-Type: text/html"
Case "zip"
ContentType = "Content-Type: application/zip"
Case "mp3"
ContentType = "Content-Type: audio/mpeg"
Case "m3u", "pls", "xpl"
ContentType = "Content-Type: audio/x-mpegurl"
Case Else
ContentType = "Content-Type: */*"
End Select
sHeader = "HTTP/1.0 200 OK" & vbNewLine & _
"Server: " & ServerName & vbNewLine & _
ContentType & vbNewLine & _
"Content-Length: " & LOF(CInfo(Index).FileNum) & vbNewLine & _
vbNewLine
CInfo(Index).TotalLength = Len(sHeader) + LOF(CInfo(Index).FileNum)
End If
Sck(Index).SendData sHeader
Else
sHeader = "HTTP/1.0 404 Not Found" & vbNewLine & "Server: " & ServerName & vbNewLine & vbNewLine
CInfo(Index).TotalLength = Len(sHeader)
Sck(Index).SendData sHeader
End If
End If
Else
sHeader = "HTTP/1.0 501 Not Implemented" & vbNewLine & "Server: " & ServerName & vbNewLine & vbNewLine
CInfo(Index).TotalLength = Len(sHeader)
Sck(Index).SendData sHeader
End If
End Sub
Private Function BuildHTMLDirList(ByVal Root As String, ByVal DirToList As String)
Dim Dirs As New Collection, Files As New Collection
Dim sDir As String, Path As String, HTML As String, K As Long
Root = Replace(Root, "/", "\")
DirToList = Replace(DirToList, "/", "\")
If Right(Root, 1) <> "\" Then Root = Root & "\"
If Left(DirToList, 1) = "\" Then DirToList = Mid(DirToList, 2)
If Right(DirToList, 1) <> "\" Then DirToList = DirToList & "\"
DirToList = Replace(DirToList, "%20", " ")
sDir = Dir(Replace(Root & DirToList, "\\", "\") & "*.*", vbArchive + vbDirectory + vbReadOnly)
Do Until Len(sDir) = 0
If sDir <> ".." And sDir <> "." Then
Path = Replace(Root & DirToList, "\\", "\") & sDir
If (GetAttr(Path) And vbDirectory) = vbDirectory Then
Dirs.Add sDir
Else
Files.Add sDir
End If
End If
sDir = Dir
Loop
HTML = "<html><body>"
If Dirs.Count > 0 Then
HTML = HTML & "<b>Directories:</b><br>"
For K = 1 To Dirs.Count
HTML = HTML & "<a href=""" & _
Replace(Replace("/" & DirToList & Dirs(K), "\", "/"), "//", "/") & """>" & _
Dirs(K) & "</a><br>" & vbNewLine
Next K
End If
If Files.Count > 0 Then
HTML = HTML & "<br><b>Files:</b><br><table width=""100%"" border=""1"" cellpadding=""3"" cellspacing=""2"">" & vbNewLine
For K = 1 To Files.Count
HTML = HTML & "<tr>" & vbNewLine
HTML = HTML & "<td width=""100%""><a href=""" & _
Replace(Replace("/" & DirToList & Files(K), "\", "/"), "//", "/") & """>" & _
Files(K) & "</a></td>" & vbNewLine
HTML = HTML & "<td nowrap>" & _
Format(FileLen(Replace(Root & DirToList, "\\", "\") & Files(K)) / 1024#, "###,###,###,##0") & _
" KBytes</td>" & vbNewLine
HTML = HTML & "</tr>" & vbNewLine
Next K
HTML = HTML & "</table>" & vbNewLine
End If
If Dirs.Count = 0 And Files.Count = 0 Then
HTML = HTML & "This folder is empty."
End If
BuildHTMLDirList = HTML & "</body></html>"
End Function
Private Sub Sck_SendComplete(Index As Integer)
If CInfo(Index).TotalSent >= CInfo(Index).TotalLength Then
Sck_Close Index
Else
tmrSendData(Index).Interval = 1
tmrSendData(Index).Enabled = True
End If
End Sub
Private Sub Sck_SendProgress(Index As Integer, ByVal bytesSent As Long, ByVal bytesRemaining As Long)
CInfo(Index).TotalSent = CInfo(Index).TotalSent + bytesSent
If CInfo(Index).FileNum > 0 Then
On Error Resume Next
lblFileProgress(Index).Caption = Right("00" & Index, 2) & " Transfering: " & CInfo(Index).FileName & " - " & _
CInfo(Index).TotalSent & " of " & LOF(CInfo(Index).FileNum) & " bytes sent, " & _
Format(CInfo(Index).TotalSent / LOF(CInfo(Index).FileNum) * 100#, "00.00") & " %Done."
If Err.Number <> 0 Then Err.Clear
End If
End Sub
Private Sub tmrSendData_Timer(Index As Integer)
On Error Resume Next
Const BufferLength As Long = 1024 * 2
Dim Buffer As String
If CInfo(Index).FileNum = -1 Then
Buffer = Left(CInfo(Index).DataStr, BufferLength)
CInfo(Index).DataStr = Mid(CInfo(Index).DataStr, BufferLength + 1)
Sck(Index).SendData Buffer
If Len(CInfo(Index).DataStr) = 0 Then CInfo(Index).FileNum = 0
ElseIf CInfo(Index).FileNum > 0 Then
If Loc(CInfo(Index).FileNum) + BufferLength > LOF(CInfo(Index).FileNum) Then
Buffer = String(LOF(CInfo(Index).FileNum) - Loc(CInfo(Index).FileNum), 0)
Else
Buffer = String(BufferLength, 0)
End If
Get CInfo(Index).FileNum, , Buffer
Sck(Index).SendData Buffer
If Loc(CInfo(Index).FileNum) >= LOF(CInfo(Index).FileNum) Then
Close CInfo(Index).FileNum
CInfo(Index).FileNum = 0
End If
End If
tmrSendData(Index).Enabled = False
End Sub
---------------------------------------------------------------------
-Şimdi project1.vbp dosyasına çift tıklayın.Visual basic açılsın.
-Yukarda Project'i tıklayın Modül ekle diyin(üstten 3.)
-Açılan modüle sayfasına da aşağıdaki kodları yapıştırın.
---------------------------------------------------------------------
Option Explicit
Public Enum IfStringNotFound
ReturnOriginalStr = 0
ReturnEmptyStr = 1
End Enum
Public Function RightLeft(ByRef Str As String, RFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStrRev(Str, RFind, , Compare)
If K = 0 Then
RightLeft = IIf(RetError = ReturnOriginalStr, Str, "")
Else
RightLeft = Left(Str, K - 1)
End If
End Function
Public Function RightRight(ByRef Str As String, RFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStrRev(Str, RFind, , Compare)
If K = 0 Then
RightRight = IIf(RetError = ReturnOriginalStr, Str, "")
Else
RightRight = Mid(Str, K + 1, Len(Str))
End If
End Function
Public Function LeftLeft(ByRef Str As String, LFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStr(1, Str, LFind, Compare)
If K = 0 Then
LeftLeft = IIf(RetError = ReturnOriginalStr, Str, "")
Else
LeftLeft = Left(Str, K - 1)
End If
End Function
Public Function LeftRight(ByRef Str As String, LFind As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long
K = InStr(1, Str, LFind, Compare)
If K = 0 Then
LeftRight = IIf(RetError = ReturnOriginalStr, Str, "")
Else
LeftRight = Right(Str, (Len(Str) - Len(LFind)) - K + 1)
End If
End Function
Public Function LeftRange(ByRef Str As String, StrFrom As String, StrTo As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long, Q As Long
K = InStr(1, Str, StrFrom, Compare)
If K > 0 Then
Q = InStr(K + Len(StrFrom), Str, StrTo, Compare)
If Q > K Then
LeftRange = Mid(Str, K + Len(StrFrom), (Q - K) - Len(StrFrom))
Else
LeftRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
Else
LeftRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
End Function
Public Function RightRange(ByRef Str As String, StrFrom As String, StrTo As String, Optional Compare As VbCompareMethod = vbBinaryCompare, Optional RetError As IfStringNotFound = ReturnOriginalStr) As String
Dim K As Long, Q As Long
K = InStrRev(Str, StrTo, , Compare)
If K > 0 Then
Q = InStrRev(Str, StrFrom, K, Compare)
If Q > 0 Then
RightRange = Mid(Str, Q + Len(StrFrom), (K - Q) - Len(StrTo))
Else
RightRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
Else
RightRange = IIf(RetError = ReturnOriginalStr, Str, "")
End If
End Function
Public Function SOUNDEX(Word As String) As String
Dim K As Integer, PrevNum As Integer, Num As Integer, LLetter As String
Dim SoundX As String
For K = 2 To Len(Word)
LLetter = LCase(Mid$(Word, K, 1))
Select Case LLetter
Case "b", "f", "p", "v"
Num = 1
Case "c", "e", "g", "j", "k", "q", "s", "x", "z"
Num = 2
Case "d", "t"
Num = 3
Case "l"
Num = 4
Case "m", "n"
Num = 5
Case "r"
Num = 6
Case "a", "e", "i", "o", "u"
Num = 7
End Select
If PrevNum <> Num Then
PrevNum = Num
SoundX = SoundX & Num
End If
Next K
SoundX = Replace(SoundX, "7", "", , , vbBinaryCompare)
SOUNDEX = UCase(Left(Word, 1)) & Left(SoundX & "000", 3)
End Function
Public Function SOUNDEX2(Word As String, Optional StrLength As Integer = 8) As String
Dim K As Integer, PrevNum As Integer, Num As Integer, LLetter As String
Dim SoundX As String
For K = 2 To Len(Word)
LLetter = LCase(Mid(Word, K, 1))
Select Case LLetter
Case "b", "f", "p", "v"
Num = 1
Case "c", "e", "g", "j", "k", "q", "s", "x", "z"
Num = 2
Case "d", "t"
Num = 3
Case "l"
Num = 4
Case "m", "n"
Num = 5
Case "r"
Num = 6
Case "a", "e", "i", "o", "u"
Num = 7
End Select
If PrevNum <> Num Then
PrevNum = Num
SoundX = SoundX & Num
End If
Next K
SoundX = Replace(SoundX, "7", "", , , vbBinaryCompare)
SOUNDEX2 = UCase(Left(Word, 1)) & Left(SoundX & String(StrLength - 1, "0"), StrLength - 1)
End Function
--------------------------------------------------------------------------
-Evet şimdi programı çalıştırın.En sevdiğiniz tarayıcıyı açın localhost:9999 yazıp enter a basın.
-Çalışıyor değil mi?Şimdi ister düzenleyin ister direk derleyip kaydedin.
-Hiç kod yazmadan bir program daha yazdığınız için kendinize SAYGI DUYUN....
Son düzenleme:
