SourceCode.in.th ::Source,code,Article,Programming,C++Builder,Delphi,Java,Visual Basic,VB6,Web,Tutorial,ASP,PHP,Java,C,C++,VC,CGI,Perl,Free,Winsock,ActiveX,COM,jQuery,Android

คือ ผมงง นะครับว่าเราจะมีวิธีอย่างไรให้เรียกหน้าเว็บเพจ ที่เขียนไว้แล้วในsever จำลองแล้ว พอเรียกผ่าน localhost แล้ว จะเรียกหน้า ที่เราเขียนไว้ในserver ขึ้นมาอะครับ
แนะนำด้วยครับ

Dim HTTPs As Byte
Public pwrite, pread As Integer
'Public Magic, user, pass As String
'Public lUser, Lpass As String
Public data As Integer

Private Sub btnAddIp_Click()
rasp = InputBox("enter the IP", "IP rules")
If rasp <> "" Then lstIPs.AddItem rasp
End Sub

Private Sub btnEdit_Click()
frmEdit.Show
End Sub

Private Sub btnExit_Click()
Out pwrite, &H2
RemoveFromTray
End
End Sub

'HTTP server functions
Public Sub btnHTTPon_Click()
On Error Resume Next
sckHTTP(0).LocalPort = txtHTTPport.Text

Do While sckHTTP(0).State <> sckClosed
sckHTTP(0).Close
DoEvents
Loop

sckHTTP(0).Listen

Label5.Caption = "Network Connected"
Label5.BackColor = vbGreen
Label5.ForeColor = vbBlack
lblBrowse.Visible = True
lblAddress.Visible = True
lblAddress.Caption = sckHTTP(0).LocalIP & ":" & txtHTTPport.Text

For i = 0 To 1
If optHTTP(i).Value = False Then optHTTP(i).Enabled = False
Next i

'RemoveFromTray

' AddToTray Me, mnu.option1
' SetTrayIcon frmMain.Icon
' SetTrayTip
'frmMain.Hide
'On Error Resume Next

End Sub

Public Sub btnHTTPoff_Click()
On Error Resume Next
For i = 1 To HTTPs
sckHTTP(i).Close
Unload sckHTTP(i)
Next i
sckHTTP(0).Close
Label5.Caption = "Network Connection Closed"
Label5.BackColor = vbRed
Label5.ForeColor = vbWhite
lblBrowse.Visible = False
lblAddress.Visible = False

For i = 0 To 1
If optHTTP(i).Value = False Then optHTTP(i).Enabled = True
Next i

End Sub

Private Sub btnRemoveIp_Click()
If lstIPs.ListIndex <> -1 Then lstIPs.RemoveItem (lstIPs.ListIndex)
End Sub

Private Sub cmdDOOR1_Click()
Call ctrlDoor1

End Sub

Private Sub cmdDOOR2_Click()
Call ctrlDoor2

End Sub

Private Sub cmdLight_Click()
Call ctrlLight
End Sub

Private Sub Form_Load()
pread = &H379
pwrite = &H378

IsAdmin = False
Out pwrite, &H2
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
Me.PopupMenu mnu.Option2
End If
End Sub

Private Sub Form_Terminate()
RemoveFromTray
End
End Sub

Private Sub frmHTTP_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
Me.PopupMenu mnu.Option2
End If
End Sub

Private Sub Label12_Click()
frmAbout.Show
End Sub

Public Sub sckHTTP_close(Index As Integer)
If Index <> 0 Then
sckHTTP(Index).Close
Unload sckHTTP(Index)
HTTPs = HTTPs - 1
End If
End Sub

Public Sub sckhttp_ConnectionRequest(Index As Integer, ByVal requestID As Long)
On Error Resume Next
If Index = 0 Then
If checkIPlist(sckHTTP(0).RemoteHostIP) = 1 Then Exit Sub
HTTPs = HTTPs + 1
Load sckHTTP(HTTPs)
sckHTTP(HTTPs).LocalPort = 0
sckHTTP(HTTPs).accept requestID
End If
End Sub

Public Sub sckHTTP_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim data As String
Dim cmd As String

sckHTTP(Index).GetData data
'Debug.Print data
If Mid$(data, 1, 3) = "GET" Then
If optHTTP(0).Enabled = True Then
sendHTTP Index, ""
Else
sendWAP Index, ""
End If
ElseIf Mid$(data, 1, 4) = "POST" Then
cmd = Mid(data, InStr(1, data, "Command=") + 8, Len(data))
Call sendCmdResult(Index, cmd)
End If

End Sub

Public Sub sckhttp_sendcomplete(Index As Integer)
sckHTTP(Index).Close
Unload sckHTTP(Index)
HTTPs = HTTPs - 1
End Sub

ส่วนนี้นะครับ Index.html
'Index ¢Í§¿ÍÃìÁ http internet browser
Public Sub sendHTTP(ByVal Index As Integer, ByVal HTTPdata As String)

initPage = "<html><head><title>- - -Server Control System- - -</title>" _
& "</head><body bgcolor=#000000 text=#0099CC>" _
& "Server Control" _
& "<hr><form name=form1 method=POST> <input type=submit " _
& "name=Send value=Command:> <input type=text name=Command size=36>" _
& "</form><hr> Command Control =============================== [Long Command] [Short Command] [Command Arguments] =============================== [/lockdoor1] [/11] Lock Door1 ===================== [/lockdoor2] [/21] Lock Door2 ===================== [/openlight] [/31] Open Light ===================== [/unlockdoor1] [/10] Unlock Door1 ===================== [/unlockdoor2] [/20] Unlock Door2 ===================== [/closelight] [/30] Close Light ====================="

'á»ÅÊÓËÃÑºÍØ»¡Ã³ì browser
HTTPdata = Replace(HTTPdata, "<", "<")
HTTPdata = Replace(HTTPdata, ">", ">")
HTTPdata = Replace(HTTPdata, " ", " ")
HTTPdata = Replace(HTTPdata, vbCrLf, " ")
HTTPdata = "" & HTTPdata & "</body></html>"

httpTemp = mimeHeader(200, Len(initPage) + 14 + Len(HTTPdata), "", "keep-alive") _
& initPage & HTTPdata
sckHTTP(Index).SendData httpTemp
'Debug.Print httpTemp
End Sub

Public Sub sendWAP(ByVal Index As Integer, ByVal HTTPdata As String)

initPage = "<?xml version=""1.0"" encoding=""iso-8859-1""?>" & vbCrLf _
& "<!DOCTYPE wml PUBLIC ""-//WAPFORUM//DTD WML 1.3//EN"" ""http://www.wapforum.org/DTD/wml13.dtd"">" & vbCrLf _
& "<wml>" & vbCrLf & "<card id=""init"" title=""---Mobile Control---"">" & vbCrLf _
& "Command Control : <input type=""text"" name=""Command""/><do type=""accept"" label=""send""><go method=""post"" href=""http://" & sckHTTP(0).LocalIP & ":" & sckHTTP(0).LocalPort & """><postfield name=""Command"" value=""$(Command)""/></go></do>" & vbCrLf & "/lockdoor1 /11/lockdoor2 /21/openlight /31/unlockdoor1 /10/unlockdoor2 /20/closelight /30" & vbCrLf _

'á»ÅÊÓËÃÑºÍØ»¡Ã³ì wap
HTTPdata = Replace(HTTPdata, "<", "<")
HTTPdata = Replace(HTTPdata, ">", ">")
HTTPdata = Replace(HTTPdata, vbCrLf, " ")

If Len(initPage) + Len(HTTPdata) > 1800 Then HTTPdata = Mid(HTTPdata, 1, 1800)

HTTPdata = HTTPdata & "</card></wml>"

httpTemp = "HTTP/1.1 200 OK" & vbCrLf _
& "Date: " & Format(Now, "ddd, d mmm yyyy ") & Format(sTime, " hh:mm:ss ") & "GMT" & vbCrLf _
& "Server: Mobile Control Server" & vbCrLf _
& "Last-Modified: " & Format(Now, "ddd, d mmm yyyy ") & Format(sTime, " hh:mm:ss ") & "GMT" & vbCrLf _
& "Accept-Ranges: bytes" & vbCrLf _
& "Content-Length: " & Len(initPage) + Len(HTTPdata) & vbCrLf _
& "Connection: keep-alive" & vbCrLf _
& "Content-Type: text/vnd.wap.wml" & vbCrLf & vbCrLf _
& initPage & HTTPdata

sckHTTP(Index).SendData httpTemp
'Debug.Print httpTemp
End Sub

Function mimeHeader(httpCode As Integer, dataLength As Long, fileExt As String, conType As String) As String
Dim mimeType As String
Dim sDate As Date
Dim sTime As Date
sDate = Date
sTime = Time
Select Case fileExt
Case "htm": mimeType = "text/html"
Case "wml": mimeType = "text/vnd.wap.wml ;charset=UTF-8"
Case Else: mimeType = "text/plain"
End Select

mimeHeader = "HTTP/1.0 " & Str(httpCode) & " " & getReason(httpCode) & vbCrLf _
& "Date: " & Format(sDate, "ddd, d mmm yyyy ") & Format(sTime, " hh:mm:ss ") & "GMT" & vbCrLf _
& "Server: Server Control System" & vbCrLf _
& "MIME-version: 1.0" & vbCrLf _
& "Content-type: " & mimeType & vbCrLf _
& "Connection: " & conType & vbCrLf _
& "Content-length: " & Str(dataLength) & vbCrLf & vbCrLf
End Function

Function getReason(httpCode As Integer) As String
Select Case httpCode
Case 200: getReason = "OK"
Case 201: getReason = "Created"
Case 202: getReason = "Accepted"
Case 204: getReason = "No Content"
Case 304: getReason = "Not Modified"
Case 400: getReason = "Bad Request"
Case 401: getReason = "Unauthorized"
Case 403: getReason = "Forbidden"
Case 404: getReason = "Not Found"
Case 500: getReason = "Internal Server Error"
Case 501: getReason = "Not Implemented"
Case 502: getReason = "Bad Gateway"
Case 503: getReason = "Service Unavailable"
Case Else: getReason = "Unknown"
End Select
End Function

Public Sub sendCmdResult(Index As Integer, ByVal cmd As String)
xtemp = cmdResult(Index, cmd)
If xtemp <> "" Then
If optHTTP(0).Value = True Then
sendHTTP Index, xtemp
Else
sendWAP Index, xtemp
End If
End If
End Sub

Public Function checkIPlist(hostIP As String) As Byte
If lstIPs.ListCount = 0 Then checkIPlist = 1
For i = 0 To lstIPs.ListCount - 1
If Option1.Value = True Then
If hostIP = Trim(lstIPs.List(i)) Then Exit Function
Else
If hostIP = Trim(lstIPs.List(i)) Then
checkIPlist = 1
Exit Function
End If
End If
Next i
End Function

Public Function cmdResult(Index As Integer, ByVal cmd As String) As String
On Error Resume Next
'first we translate from http
cmd = Replace(cmd, vbCrLf, "", , , vbTextCompare)
cmd = Replace(cmd, "+", " ", , , vbTextCompare)
cmd = Replace(cmd, "%20", " ", , , vbTextCompare)
cmd = Replace(cmd, "%21", "!", , , vbTextCompare)
cmd = Replace(cmd, "%22", Chr(34), , , vbTextCompare)
cmd = Replace(cmd, "%A7", "§", , , vbTextCompare)
cmd = Replace(cmd, "%24", "$", , , vbTextCompare)
cmd = Replace(cmd, "%25", "%", , , vbTextCompare)
cmd = Replace(cmd, "%26", "&", , , vbTextCompare)
cmd = Replace(cmd, "%2F", "/", , , vbTextCompare)
cmd = Replace(cmd, "%28", "(", , , vbTextCompare)
cmd = Replace(cmd, "%29", ")", , , vbTextCompare)
cmd = Replace(cmd, "%3D", "=", , , vbTextCompare)
cmd = Replace(cmd, "%3F", "?", , , vbTextCompare)
cmd = Replace(cmd, "%B2", "²", , , vbTextCompare)
cmd = Replace(cmd, "%B3", "³", , , vbTextCompare)
cmd = Replace(cmd, "%7B", "{", , , vbTextCompare)
cmd = Replace(cmd, "%5B", "[", , , vbTextCompare)
cmd = Replace(cmd, "%5D", "]", , , vbTextCompare)
cmd = Replace(cmd, "%7D", "}", , , vbTextCompare)
cmd = Replace(cmd, "%5C", "\", , , vbTextCompare)
cmd = Replace(cmd, "%DF", "ß", , , vbTextCompare)
cmd = Replace(cmd, "%23", "#", , , vbTextCompare)
cmd = Replace(cmd, "%27", "'", , , vbTextCompare)
cmd = Replace(cmd, "%3A", ":", , , vbTextCompare)
cmd = Replace(cmd, "%2C", ",", , , vbTextCompare)
cmd = Replace(cmd, "%3B", ";", , , vbTextCompare)
cmd = Replace(cmd, "%60", "`", , , vbTextCompare)
cmd = Replace(cmd, "%7E", "~", , , vbTextCompare)
cmd = Replace(cmd, "%2B", "+", , , vbTextCompare)
cmd = Replace(cmd, "%B4", "´", , , vbTextCompare)

If cmd = "?" Then
cmdResult = openPage(App.Path & "\webcommands.txt")
Exit Function
End If

If Left(cmd, 1) = "/" Then
spcol = InStr(1, cmd, " ")
If spcol < 1 Then spcol = Len(cmd) + 1
args = Mid(cmd, spcol + 1, Len(cmd))
cmd = Mid(cmd, 2, spcol - 2)
Else
args = cmd
cmd = "65"
End If

Select Case LCase(cmd)
Case "help"
ts = openPage(App.Path & "\webcommands.txt")
Case "xx", "exit"
End
Case "11", "lockdoor1"
Call webD1Lock
ts = "Door 1 locked successfull"
Case "21", "lockdoor2"
Call webD2Lock
ts = "Door 2 locked successfull"
Case "31", "openlight"
Call webLightOpen
ts = "Light Opened successfull"
Case "10", "unlockdoor1"
Call webD1Unlock
ts = "Door 1 Unlocked "
Case "20", "unlockdoor2"
Call webD2Unlock
ts = "Door 2 Unlocked "
Case "30", "closelight"
Call webLightClose
ts = "Light Closed "
'Case "wapcommand"
'Call checkWap
'MsgBox checkWap
'ts = openPage(App.Path & "\wapcommands.wml")
'Case "chkstatus"
' Call check
' ts = openPage(App.Path & "\status.dat")
Case "1131", "lockdoor1openlight"
Out pwrite, &H5
shpDOOR(0).BackColor = vbGreen
shpDOOR(2).BackColor = vbYellow
ts = "Door1 Locked and Light Opened "
Case "2131", "lockdoor2openlight"
Out pwrite, &H4
shpDOOR(1).BackColor = vbGreen
shpDOOR(2).BackColor = vbYellow
ts = "Door2 Locked and Light Opened "
Case "1031", "unlockdoor1openlight"
Out pwrite, &H4
shpDOOR(0).BackColor = vbRed
shpDOOR(2).BackColor = vbYellow
ts = "Door1 Unlocked and Light Opened "
Case "2031", "unlockdoor2openlight"
Out pwrite, &H6
shpDOOR(1).BackColor = vbRed
shpDOOR(2).BackColor = vbYellow
ts = "Door2 Unlocked and Light Opened "
Case "1130", "lockdoor1closelight"
Out pwrite, &H1
shpDOOR(0).BackColor = vbGreen
shpDOOR(2).BackColor = vbBlack
ts = "Door1 Locked and Light Closed "
Case "2130", "lockdoor2closelight"
Out pwrite, &H0
shpDOOR(1).BackColor = vbGreen
shpDOOR(2).BackColor = vbBlack
ts = "Door2 Locked and Light Closed "
Case "1121", "lockdoor1lockdoor2"
Out pwrite, &H1
shpDOOR(0).BackColor = vbGreen
shpDOOR(1).BackColor = vbGreen
ts = "Door1 Locked and Door2 Locked "
Case "1021", "unlockdoor1lockdoor2 "
Out pwrite, &H0
shpDOOR(0).BackColor = vbRed
shpDOOR(1).BackColor = vbGreen
ts = "Door1 Unlocked and Door2 Locked "
Case "1020", "unlockdoor1unlockdoor2"
Out pwrite, &H4
shpDOOR(0).BackColor = vbRed
shpDOOR(1).BackColor = vbRed
ts = "Door1Unlocked and Door2 Unlocked "
Case "112131", "lockdoor1lockdoor2openlight"
Out pwrite, &H5
shpDOOR(0).BackColor = vbGreen
shpDOOR(1).BackColor = vbGreen
shpDOOR(2).BackColor = vbYellow
ts = "Door1 Locked Door2 Locked Light Opened "
Case "102030", "unlockdoor1unlockdoor2closelight"
Out pwrite, &H2
shpDOOR(0).BackColor = vbRed
shpDOOR(1).BackColor = vbRed
shpDOOR(2).BackColor = vbBlack
ts = "Door1 Unlocked Door2 Unlocked Light Closed"
Case "1030", "unlockdoor1closelight"
Out pwrite, &H0
Out pwrite, &H2
shpDOOR(0).BackColor = vbRed
shpDOOR(2).BackColor = vbBlack
ts = "Door1 Unlocked and Light Closed "
Case "2030", "unlockdoor2closelight"
Out pwrite, &H2
shpDOOR(1).BackColor = vbRed
shpDOOR(2).BackColor = vbBlack
ts = "Door1 Locked and Light Closed "
Case Else
ts = "/" & cmd & args & " is not recognized as a valid command." &
End Select
cmdResult = ts
End Function

Public Function openPage(ByVal Filename As String) As String
On Error GoTo errore
freefileNr = FreeFile
If LCase(Dir(Filename)) <> LCase(JustName(Filename)) Then GoTo errore
Open Filename For Binary Access Read As #freefileNr
openPage = Space(LOF(freefileNr))
Get #freefileNr, , openPage
Close freefileNr
Exit Function
errore:
openPage = "error: could not load specified file."
End Function

Public Sub ctrlDoor1()
If shpDOOR(0).BackColor = vbRed Then
cmdDOOR1.Enabled = True
Out pwrite, &H1
shpDOOR(0).BackColor = vbGreen
Else: shpDOOR(0).BackColor = vbRed
Out pwrite, &H0
End If
End Sub
Public Sub ctrlDoor2()
If shpDOOR(1).BackColor = vbRed Then
cmdDOOR2.Enabled = True
Out pwrite, &H0
shpDOOR(1).BackColor = vbGreen
Else: shpDOOR(1).BackColor = vbRed
Out pwrite, &H2
End If
End Sub
Public Sub ctrlLight()
If shpDOOR(2).BackColor = vbBlack Then
cmdLight.Enabled = True
Out pwrite, &H4
shpDOOR(2).BackColor = vbYellow
Else: shpDOOR(2).BackColor = vbBlack
Out pwrite, &H0
End If
End Sub

Public Function JustName(ByVal s As String) As String
i = Len(s)
Do While Mid(s, i, 1) <> "\"
i = i - 1
If i = 0 Then Exit Do
Loop
If i > 1 Then
JustName = Right(s, Len(s) - i)
Else
JustName = s
End If
End Function

Public Sub webD1Lock()
Out pwrite, &H1
shpDOOR(0).BackColor = vbGreen
End Sub

Public Sub webD2Lock()
Out pwrite, &H0
shpDOOR(1).BackColor = vbGreen
End Sub

Public Sub webLightOpen()
Out pwrite, &H4
shpDOOR(2).BackColor = vbYellow
End Sub

Public Sub webD1Unlock()
Out pwrite, &H0
shpDOOR(0).BackColor = vbRed
End Sub

Public Sub webD2Unlock()
Out pwrite, &H2
shpDOOR(1).BackColor = vbRed
End Sub

Public Sub webLightClose()
Out pwrite, &H0
shpDOOR(2).BackColor = vbBlack
End Sub

Private Sub Timer1_Timer()
Dim onDevice, onMinute As String
Dim a, b, c, d, e, f As String

lblTimeInfo.Caption = Time()
a = Hour(Time)
b = Minute(Time)
a = Val(a)
b = Val(b)

onDevice = txtStartTime.Text
onMinute = txtMinstart.Text

SetTime = Val(onDevice)
SetMinute = Val(onMinute)
c = Int(SetTime)
'd = (SetTime - c) * 100
d = Int(SetMinute)
If a - c = 0 And b - d = 0 Then
'MsgBox chkDoor(0).Value & chkDoor(1).Value & chkDoor(2).Value
'Exit Sub
If chkDoor(1).Value = 1 Then
shpDOOR(1).BackColor = vbGreen
Out pwrite, &H0
Else
Out pwrite, &H2
shpDOOR(1).BackColor = vbRed
End If

If chkDoor(0).Value = 1 Then
shpDOOR(0).BackColor = vbGreen
Out pwrite, &H1
End If

If chkDoor(2).Value = 1 Then
shpDOOR(2).BackColor = vbYellow
Out pwrite, &H4
End If

If chkDoor(0).Value = 1 Then
If chkDoor(2).Value = 1 Then
Out pwrite, &H5
shpDOOR(0).BackColor = vbGreen
shpDOOR(2).BackColor = vbYellow
End If
End If

If chkDoor(1).Value = 1 Then
If chkDoor(2).Value = 1 Then
Out pwrite, &H4
shpDOOR(1).BackColor = vbGreen
shpDOOR(2).BackColor = vbYellow
End If
End If

If chkDoor(0).Value = 1 Then
If chkDoor(1).Value = 1 Then
Out pwrite, &H0
If chkDoor(2).Value = 1 Then
Out pwrite, &H5
shpDOOR(0).BackColor = vbGreen
shpDOOR(1).BackColor = vbGreen
shpDOOR(2).BackColor = vbYellow
End If
End If
End If

If chkDoor(0).Value = 1 Then
If chkDoor(1).Value = 1 Then
Out pwrite, &H1
shpDOOR(0).BackColor = vbGreen
shpDOOR(1).BackColor = vbGreen
End If
End If

End If

SetHour = txtHour.Text
SetMin = txtMinute.Text
SetHour = Val(SetHour)
SetMin = Val(SetMin)
e = c + SetHour
f = d + SetMin
If e > 23 Then e = e - 24
If f > 59 Then
f = f - 60
e = e + 1
End If
If a - e = 0 And b - f = 0 Then
shpDOOR(0).BackColor = vbRed
shpDOOR(1).BackColor = vbRed
shpDOOR(2).BackColor = vbBlack

Out pwrite, &H0
Out pwrite, &H2
chkDoor(0).Value = 0
chkDoor(1).Value = 0
chkDoor(2).Value = 0
txtStartTime.Text = ""
txtMinstart.Text = ""
End If

End Sub

Private Sub txtHour_Change()
SetHour = txtHour.Text
SetHour = Val(SetHour)
Select Case SetHour
Case Is > 23
MsgBox "¤èÒ·ÕèµéÍ§ãÊèÁÕ¤èÒÃÐËÇèÒ§ 1-23", vbCritical + vbOKOnly, "ERROR"
txtHour.Text = ""
Case Is < 1
MsgBox "¤èÒ·ÕèµéÍ§ãÊèÁÕ¤èÒÃÐËÇèÒ§ 1-23", vbCritical + vbOKOnly, "ERROR"
txtHour.Text = ""
End Select
End Sub

Private Sub txtMinute_Change()
SetMin = txtMinute.Text
SetMin = Val(SetMin)
Select Case SetMin
Case Is > 59
MsgBox "¤èÒ·ÕèµéÍ§ãÊèÁÕ¤èÒÃÐËÇèÒ§ 1-59", vbCritical + vbOKOnly, "ERROR"
txtMinute.Text = ""
Case Is < 1
MsgBox "¤èÒ·ÕèµéÍ§ãÊèÁÕ¤èÒÃÐËÇèÒ§ 1-59", vbCritical + vbOKOnly, "ERROR"
txtMinute.Text = ""
End Select
End Sub

ขอบพระคุณล่วงหน้าครับ

จะทำยังงัยให้ติดต่อกับserver จำลองส่งหน้าเว็บ แล้วเรียกผ่าน localhost ได้ ครับ