I`m having a problem with the connection from the client to the server. when more than 4 people from the same ip try to connect to the server the client start flashing and you have to end the process from the task manager . And also if can be setup how many clients per device .. Thanks
This is a 2d mmorpg game called Xiaspora . The game will not be used for generating money its just for fun with my friends and their friends .
Client winsock
Dim Reconnect As Boolean
Sub Connect()
Dim serveraddress As String
Dim serverport As String
If Start.Client.State = 0 Then
ReadInfoText serveraddress, serverport
Start.Client.Connect serveraddress, serverport
End If
End Sub
Sub Disconnect()
Start.ConnectTestTimer.Enabled = False
AddPrivChatText 3, "Disconnected... Attempting to Reconnect"
If Reconnect = True Then
Start.Client.Close
Start.Client.Connect
Else
CloseProgram
End If
End Sub
Sub SendMessage(Message As String)
If Start.Client.State = 7 Then
Start.Client.SendData Message & Chr(13)
End If
End Sub
Sub SendChatMessage(Message As String)
Dim check As Integer
Dim checkmessage As String
If Len(Message) = 0 Then Exit Sub
If Mid(Message, 1, 4) = ":g::" Then
SendMessage "4," & Message
Exit Sub
End If
If Mid(Message, 1, 4) = ":G::" Then
SendMessage "4," & Message
Exit Sub
End If
checkmessage = Mid(Message, 1, 30)
Do
check = check + 1
If Mid(checkmessage, check, 2) = "::" Then Exit Do
Loop Until check = Len(checkmessage)
If check = Len(checkmessage) Then
SendMessage "4," & Message
Else
SendMessage "5," & Mid(Message, 1, check - 1) & "," & Mid(Message, check + 2)
End If
End Sub
Sub SetReloginTrue()
Reconnect = True
End Sub
Sub SetReloginFalse()
Reconnect = False
End Sub
Function Relogin() As Boolean
Relogin = Reconnect
End Function
Option Explicit
Dim intWCount As Integer 'Number of winsocks in the array
Dim PacketCheck(3200) As Integer
Sub AddServerLogText(Message As String)
'WriteSub "Winsock-addserverlogtext" & Message
If Len(Main.ServerLogText.Text) > 15000 Then
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Mid(Main.ServerLogText.Text, 1, 14000)
Else
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Main.ServerLogText.Text
End If
End Sub
Sub StartServer()
Dim ThePort As String
ReadInfoText ThePort
Main.Server(0).LocalPort = ThePort
Main.Server(0).Listen
AddServerLogText "Server Now Running on Port " & ThePort
End Sub
Sub CloseCon(Index As Integer)
On Error Resume Next
If Index = 0 Then Exit Sub
LogOutProcedure Index
WriteSub "Winsock-closecon"
Main.Server(Index).Close
Unload Main.EngageTimer(Index)
AddServerLogText Index & ": Closed"
PacketCheck(Index) = 0
End Sub
Sub ConnectionRequestCon(ByVal requestID As Long)
On Error Resume Next
Dim check As Integer
Dim LoggedOn As Integer
Dim NewIndex As Integer
Dim RandomCheck As Integer
NewIndex = GetFreeIndex
LogOutProcedure NewIndex
RandomizeConLandLaunch NewIndex
Load Main.Server(NewIndex)
Load Main.EngageTimer(NewIndex)
Main.Server(NewIndex).Accept requestID
AddServerLogText NewIndex & ": Connected [" & Main.Server(NewIndex).RemoteHostIP & "]"
RandomCheck = RandomNumber(1000, 30000)
SetConAuthNumber NewIndex, RandomCheck
Main.Server(NewIndex).SendData "1,Welcome To Xiaspora - " & TotalLogedInUsers & " Users Online" & Chr(13) & "34," & RandomCheck & Chr(13)
DoEvents
Do
check = check + 1
If Main.Server(check).State = 7 And Main.Server(check).RemoteHostIP = Main.Server(NewIndex).RemoteHostIP Then LoggedOn = LoggedOn + 1
Loop Until check = Main.Server.Count
If LoggedOn >= 6 Then CloseCon NewIndex
End Sub
Function GetFreeIndex() As Integer
WriteSub "Winsock-getfreeindex"
On Error Resume Next
Dim check As Long
For check = 1 To Main.Server.Count
If Main.Server(check).State <> 9 Then
Main.Server(check).Close
GetFreeIndex = check
Exit Function
End If
If check > Main.Server.Count Then
GetFreeIndex = Main.Server.Count + 1
Exit Function
End If
Next
intWCount = intWCount + 1
GetFreeIndex = intWCount
End Function
Sub GetDataCon(Index As Integer)
WriteSub "Winsock-getdatacon"
Dim themax As Integer
Dim ndata As String
Dim check As Integer
Dim curloc As Integer
Main.Server(Index).GetData ndata
Dim num As Integer
num = FreeFile
Open "lastpack.txt" For Output As num
Print #num, Date & " " & Time & " " & ndata
Close num
themax = MaxPack(ndata)
Do
check = check + 1
PacketCheck(Index) = PacketCheck(Index) + 1
If PacketCheck(Index) = 50 Then
CloseCon Index
Exit Sub
End If
If PacketCheck(Index) < 20 Then CheckMode Index, ReadPackS(ndata, curloc)
Loop Until check >= themax
If themax > 1 Then PacketCheck(Index) = PacketCheck(Index) - 1
End Sub
Sub PrivMsg(ToCon As Integer, Message As String)
WriteSub "Winsock-privmsg"
On Error GoTo FuCK
If ToCon = 0 Then Exit Sub
If Main.Server(ToCon).State = 7 Then
If GetConDebug(ToCon) = True Then AddServerLogText ToCon & ": Snt - " & Message 'Only During Problems
If GetConDebugFull(ToCon) = True Then WriteDebugLog ToCon, "Snt - " & Message ' If you have problems
'AddServerLogText ToCon & ": Snt - " & Message '--Temp Debug Purposes
Main.Server(ToCon).SendData Message & Chr(13)
DoEvents
End If
Exit Sub
FuCK:
AddServerLogText ToCon & ": Snt - ERROR ERROR ERROR " & Message
LogOutProcedure ToCon
End Sub
Sub PacketCheckReduce()
Dim check As Integer
Do
check = check + 1
If PacketCheck(check) > 0 Then PacketCheck(check) = PacketCheck(check) - 2
If PacketCheck(check) < 0 Then PacketCheck(check) = 0
Loop Until check >= Main.Server.Count
End Sub
Server Winsock
Option Explicit
Dim intWCount As Integer 'Number of winsocks in the array
Dim PacketCheck(3200) As Integer
Sub AddServerLogText(Message As String)
'WriteSub "Winsock-addserverlogtext" & Message
If Len(Main.ServerLogText.Text) > 15000 Then
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Mid(Main.ServerLogText.Text, 1, 14000)
Else
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Main.ServerLogText.Text
End If
End Sub
Sub StartServer()
Dim ThePort As String
ReadInfoText ThePort
Main.Server(0).LocalPort = ThePort
Main.Server(0).Listen
AddServerLogText "Server Now Running on Port " & ThePort
End Sub
Sub CloseCon(Index As Integer)
On Error Resume Next
If Index = 0 Then Exit Sub
LogOutProcedure Index
WriteSub "Winsock-closecon"
Main.Server(Index).Close
Unload Main.EngageTimer(Index)
AddServerLogText Index & ": Closed"
PacketCheck(Index) = 0
End Sub
Sub ConnectionRequestCon(ByVal requestID As Long)
On Error Resume Next
Dim check As Integer
Dim LoggedOn As Integer
Dim NewIndex As Integer
Dim RandomCheck As Integer
NewIndex = GetFreeIndex
LogOutProcedure NewIndex
RandomizeConLandLaunch NewIndex
Load Main.Server(NewIndex)
Load Main.EngageTimer(NewIndex)
Main.Server(NewIndex).Accept requestID
AddServerLogText NewIndex & ": Connected [" & Main.Server(NewIndex).RemoteHostIP & "]"
RandomCheck = RandomNumber(1000, 30000)
SetConAuthNumber NewIndex, RandomCheck
Main.Server(NewIndex).SendData "1,Welcome To Xiaspora - " & TotalLogedInUsers & " Users Online" & Chr(13) & "34," & RandomCheck & Chr(13)
DoEvents
Do
check = check + 1
If Main.Server(check).State = 7 And Main.Server(check).RemoteHostIP = Main.Server(NewIndex).RemoteHostIP Then LoggedOn = LoggedOn + 1
Loop Until check = Main.Server.Count
If LoggedOn >= 6 Then CloseCon NewIndex
End Sub
Function GetFreeIndex() As Integer
WriteSub "Winsock-getfreeindex"
On Error Resume Next
Dim check As Long
For check = 1 To Main.Server.Count
If Main.Server(check).State <> 9 Then
Main.Server(check).Close
GetFreeIndex = check
Exit Function
End If
If check > Main.Server.Count Then
GetFreeIndex = Main.Server.Count + 1
Exit Function
End If
Next
intWCount = intWCount + 1
GetFreeIndex = intWCount
End Function
Sub GetDataCon(Index As Integer)
WriteSub "Winsock-getdatacon"
Dim themax As Integer
Dim ndata As String
Dim check As Integer
Dim curloc As Integer
Main.Server(Index).GetData ndata
Dim num As Integer
num = FreeFile
Open "lastpack.txt" For Output As num
Print #num, Date & " " & Time & " " & ndata
Close num
themax = MaxPack(ndata)
Do
check = check + 1
PacketCheck(Index) = PacketCheck(Index) + 1
If PacketCheck(Index) = 50 Then
CloseCon Index
Exit Sub
End If
If PacketCheck(Index) < 20 Then CheckMode Index, ReadPackS(ndata, curloc)
Loop Until check >= themax
If themax > 1 Then PacketCheck(Index) = PacketCheck(Index) - 1
End Sub
Sub PrivMsg(ToCon As Integer, Message As String)
WriteSub "Winsock-privmsg"
On Error GoTo FuCK
If ToCon = 0 Then Exit Sub
If Main.Server(ToCon).State = 7 Then
If GetConDebug(ToCon) = True Then AddServerLogText ToCon & ": Snt - " & Message 'Only During Problems
If GetConDebugFull(ToCon) = True Then WriteDebugLog ToCon, "Snt - " & Message ' If you have problems
'AddServerLogText ToCon & ": Snt - " & Message '--Temp Debug Purposes
Main.Server(ToCon).SendData Message & Chr(13)
DoEvents
End If
Exit Sub
FuCK:
AddServerLogText ToCon & ": Snt - ERROR ERROR ERROR " & Message
LogOutProcedure ToCon
End Sub
Sub PacketCheckReduce()
Dim check As Integer
Do
check = check + 1
If PacketCheck(check) > 0 Then PacketCheck(check) = PacketCheck(check) - 2
If PacketCheck(check) < 0 Then PacketCheck(check) = 0
Loop Until check >= Main.Server.Count
End Sub
Set RsItem = Conn.Execute("EXEC E_UpdateDevBehaviourSmalls #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID")& " ,#cCompID=" & cCompetenceid & " ,#reason=" &reason & " ,#comptype=" & comptype &",#GID=" & GID & " ,#Behaviour='" & MakeSendable(Behaviour) & "' ,#Deadline='" & deadlinedatetime & "' ,#DevBehaviour='" & MakeSendable(DevBehaviour) & "' ,#Why='" & MakeSendable(Why) & "' ,#ExtraNote='" & MakeSendable(ExtraNote) & "'")
if GID = 0 then
if not RsItem.eof then
GID = RsItem.fields(0).value
if reason = 0 then
'add dummy devbehaviour detail
Set RsItem =Conn.Execute("EXEC E_UpdateDevBehaviourDetail #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#GID=" & GID & " ,#DID=0 ,#TextField1='dummy' ,#educ= 0 ,#TextField2='dummy' ,#TextField3='dummy' ,#TextField4='dummy'")
end if
end if
end if
When I try to execute the code above (full code below) I got the following error:
(It gets stuck at the following part: if not RsItem.fields(0).value)
ADODB.Recordset error '800a0e78'
Operation is not allowed when the object is closed.
Can anyone help me with this error?
<%
Dim DID
Dim GID
Dim cCompetenceid
Dim Behaviour
Dim Deadline
Dim DevBehaviour
Dim Why
Dim ExtraNote
MakeConn
Session("OnlinePageID") = 106
InsertLogItem "S:12"
If Session("EUserType")=1 Then
If UCase(Request("Action"))="SAVEDETAIL" Then
If not Request("DID")="" Then
DID = Request("DID")
Else
DID = 0
End If
Conn.Execute("EXEC E_UpdateDevBehaviourDetail #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#GID=" & Request("GID") & " ,#DID=" & DID & " ,#TextField1='" & MakeSendable(Request("TextField1")) & "' ,#TextField2='" & MakeSendable(Request("TextField2")) & "' ,#TextField3='" & MakeSendable(Request("TextField3")) & "' ,#TextField4='" & MakeSendable(Request("TextField4")) & "'")
Conn.Execute("EXEC E_SignIDP #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#SignStatus=0")
End If
End If
'response.write Session("EUserType") & "<br>"
If Session("EUserType")=1 Then
Select Case UCase(Request("Action"))
Case "EDIT"
If not Request("GID")="" Then
'response.write "EXEC E_GetDevBehavior #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#GID=" & Request("GID") & "<br>"
Set RsItem = Conn.Execute("EXEC E_GetDevBehavior #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#GID=" & Request("GID"))
If not RsItem.EOF Then
Behaviour = Replace (RsItem("Behaviour"),"''","'")
Deadline = RsItem("Deadline")
DevBehaviour = Replace (RsItem("DevBehaviour"),"''","'")
Why = Replace (RsItem("Why"),"''","'")
ExtraNote = Replace (RsItem("ExtraNote"),"''","'")
Else
Response.End
End If
'RsItem.close
'Set RsItem = nothing
Else
End If
Case "SAVE"
If not Request("GID")="" Then
Set RsItem = Conn.Execute("EXEC E_GetDevBehavior #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#GID=" & Request("GID"))
If not RsItem.EOF Then
Behaviour = Replace (RsItem("Behaviour"),"''","'")
Deadline = RsItem("Deadline")
DevBehaviour = Replace (RsItem("DevBehaviour"),"''","'")
Why = Replace (RsItem("Why"),"''","'")
ExtraNote = Replace (RsItem("ExtraNote"),"''","'")
Else
Response.End
End If
'RsItem.close
'Set RsItem = nothing
end if
dag = Day(Now())
maand = Month(Now())
jaar = Year(Now())
uur = Hour(Time)
minuten = Minute(Time)
seconden = Second(Time)
if len(dag)< 2 then dag ="0" & dag
if len(maand) < 2 then maand ="0" & maand
if len(uur) < 2 then uur ="0" & uur
if len(minuten) < 2 then minuten ="0" & minuten
if len(seconden) < 2 then seconden ="0" & seconden
datum= jaar & "-" & maand & "-" & dag
tijd = uur & ":" & minuten& ":" & seconden
datumtijd = datum & " " & tijd
Conn.Execute("EXEC E_UpdatePOPStartDate #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID"))
Conn.Execute("EXEC E_UpdateStartDate #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#StartDate='" & datumtijd & "'")
If not Request("GID")="" Then
GID = Request("GID")
newcomp = false
Else
GID = 0
Deadline = CDate(FormatDate("31/12/"&year(now)))
newcomp = true
End If
'response.write Request("cCompetenceid") &"<br>"
if not Request("cCompetenceid") = "" then
cCompetenceid = Request("cCompetenceid")
else
cCompetenceid = 0
end if
if not Request("reason") = "" then
reason = Request("reason")
else
reason = 0
end if
if not Request("comptype") = "" then
comptype = Request("comptype")
else
comptype = 1
end if
Select Case (Request("COMPID"))
Case 1460
Behaviour = Request("Behaviour")
Case 1461
Deadline = Request("DeadlineDay") & "-" & Request("DeadlineMonth") & "-" & Request("DeadlineYear")
Deadline = CDate(FormatDate(Deadline))
Case 1462
DevBehaviour = Request("DevBehaviour")
Case 1463
Why = Request("Why")
Case 1464
ExtraNote = Request("ExtraNote")
End Select
deadlinedate = CDate(Deadline)
deadlineyear = year(deadlinedate)
deadlinemonth = month(deadlinedate)
deadlineday = day(deadlinedate)
deadlinedatetime = deadlineyear & "-" & deadlinemonth & "-" & deadlineday & " 00:00:00"
'response.write "EXEC E_UpdateDevBehaviourSmalls #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID")& " ,#cCompID=" & cCompetenceid & " ,#reason=" &reason & " ,#comptype=" & comptype &",#GID=" & GID & " ,#Behaviour='" & MakeSendable(Behaviour) & "' ,#Deadline='" & deadlinedatetime & "' ,#DevBehaviour='" & MakeSendable(DevBehaviour) & "' ,#Why='" & MakeSendable(Why) & "' ,#ExtraNote='" & MakeSendable(ExtraNote) & "'"
'response.end
Set RsItem = Conn.Execute("EXEC E_UpdateDevBehaviourSmalls #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID")& " ,#cCompID=" & cCompetenceid & " ,#reason=" &reason & " ,#comptype=" & comptype &",#GID=" & GID & " ,#Behaviour='" & MakeSendable(Behaviour) & "' ,#Deadline='" & deadlinedatetime & "' ,#DevBehaviour='" & MakeSendable(DevBehaviour) & "' ,#Why='" & MakeSendable(Why) & "' ,#ExtraNote='" & MakeSendable(ExtraNote) & "'")
if GID = 0 then
if not RsItem.eof then
GID = RsItem.fields(0).value
if reason = 0 then
' add dummy devbehaviour detail
Set RsItem =Conn.Execute("EXEC E_UpdateDevBehaviourDetail #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#GID=" & GID & " ,#DID=0 ,#TextField1='dummy' ,#educ= 0 ,#TextField2='dummy' ,#TextField3='dummy' ,#TextField4='dummy'")
end if
end if
end if
'RsItem.close
'Set RsItem = nothing
Conn.Execute("EXEC E_SignIDP #ClientID=" & Session("ClientID") & " ,#UserID=" & Session("EUserID") & " ,#SignStatus=0")
if newcomp = true then
tempstr = "../popoverview.asp"
ClientScript("parent.location.href = '../bottomframe.asp?GID=" & GID & "&" & SetID &"&ViewID=4'" )
else
response.write " in"
tempstr = "compoverview.asp?Action=Edit&GID="&GID
response.redirect tempstr
' ClientScript("location.href =" & tempstr)
end if
End Select
End If
conn.close
set conn= nothing
%>
Stored procedure:
USE [Q]
GO
/****** Object: StoredProcedure [dbo].[E_UpdateDevBehaviourSmalls] Script Date: 17/10/2013 15:05:53 ******/
SET ANSI_NULLS OFF
GO
SET QUOTED_IDENTIFIER ON
GO
ALTER PROCEDURE [dbo].[E_UpdateDevBehaviourSmalls]
(#ClientID int,
#UserID int,
#cCompID int,
#reason int,
#comptype int,
#GID int,
#Behaviour varchar(250),
#Deadline datetime,
#DevBehaviour text,
#Why text,
#ExtraNote text)
AS
If (#GID = 0)
BEGIN
INSERT INTO DevBehaviour(ClientID,UserID,Behaviour,Deadline,DevBehaviour,Why,ExtraNote,cCompId,reason,comptype)
VALUES(#ClientID,#UserID,#Behaviour,#Deadline,#DevBehaviour,#Why,#ExtraNote, #cCompID,#reason,#comptype)
SELECT ##identity
END
Else
BEGIN
UPDATE DevBehaviour
SET Behaviour=#Behaviour, Deadline=#Deadline, DevBehaviour=#DevBehaviour, Why=#Why, ExtraNote=#ExtraNote, cCompId = #cCompID, reason = #reason, comptype = #comptype
WHERE (ClientID = #ClientID) AND (UserID = #UserID) AND (GID = #GID)
END
I was able to reproduce your problem. Please try the stored proc below (using nocount)
USE [Q]
GO
/****** Object: StoredProcedure [dbo].[E_UpdateDevBehaviourSmalls] Script Date: 17/10/2013 15:05:53 ******/
SET ANSI_NULLS OFF
GO
SET QUOTED_IDENTIFIER ON
GO
ALTER PROCEDURE [dbo].[E_UpdateDevBehaviourSmalls]
(#ClientID int,
#UserID int,
#cCompID int,
#reason int,
#comptype int,
#GID int,
#Behaviour varchar(250),
#Deadline datetime,
#DevBehaviour text,
#Why text,
#ExtraNote text)
AS
set nocount on
If (#GID = 0)
BEGIN
INSERT INTO DevBehaviour(ClientID,UserID,Behaviour,Deadline,DevBehaviour,Why,ExtraNote,cCompId,reason,comptype)
VALUES(#ClientID,#UserID,#Behaviour,#Deadline,#DevBehaviour,#Why,#ExtraNote, #cCompID,#reason,#comptype)
SELECT ##identity
END
Else
BEGIN
UPDATE DevBehaviour
SET Behaviour=#Behaviour, Deadline=#Deadline, DevBehaviour=#DevBehaviour, Why=#Why, ExtraNote=#ExtraNote, cCompId = #cCompID, reason = #reason, comptype = #comptype
WHERE (ClientID = #ClientID) AND (UserID = #UserID) AND (GID = #GID)
END
set nocount off
I have a simple bit of code that is filling a select object from a db table. I want to check a value to set an entry as selected, but when I check a db value, I get an empty select box. This code produces the empty box:
response.write "<td><select name='FromDept'>"
Do While not rs.eof
If rs("DeptID") = 61 Then
response.write "<option value=" & rs("DeptID") & " selected>" & rs("DeptName") & "</option>"
Else
response.write "<option value=" & rs("DeptID") & ">" & rs("DeptName") & "</option>"
End If
rs.MoveNext
Loop
rs.close
response.write "</select></td>"
However, this code produces a select box with values:
response.write "<td><select name='FromDept'>"
LpCnt = 0
Do While not rs.eof
If LpCnt = 9 Then
response.write "<option value=" & rs("DeptID") & " selected>" & rs("DeptName") & "</option>"
Else
response.write "<option value=" & rs("DeptID") & ">" & rs("DeptName") & "</option>"
End If
rs.MoveNext
LpCnt = LpCnt + 1
Loop
rs.close
response.write "</select></td>"
Thanks for any help!
Assign the value to a temporary variable:
response.write "<td><select name='FromDept'>"
Do While not rs.eof
dept = rs("DeptID")
If dept = 61 Then
response.write "<option value=" & dept & " selected>" & rs("DeptName") & "</option>"
...
Empty drop down means you get error in that statement and it's ignored most likely due to On Error Resume Next line you have somewhere.
First of all, get rid of that On Error Resume Next line.
Second, error in such code means type conversion problem. Try this code instead:
Dim curDeptID
Do While not rs.eof
curDeptID = 0
If Not IsNull(rs("DeptID")) Then
curDeptID = CLng(CStr(rs("DeptID")))
End If
If curDeptID=61 Then
response.write "<option value=" & rs("DeptID") & " selected>" & rs("DeptName") & "</option>"
Else
response.write "<option value=" & rs("DeptID") & ">" & rs("DeptName") & "</option>"
End If
rs.MoveNext
Loop
The code below is how to show/split 2 rows in a table.
But how do I get it to show/split it to 4 rows and not only two ???
dim bCloseRow
bCloseRow = True
Do while not objTrucks.eof
If bCloseRow Then response.write "<tr>"
bCloseRow = Not bCloseRow
response.write "<td><input type=checkbox name=dno value=" & objTrucks("TRUCK_NO") & objTrucks("TRUCK_NO") & ">" & objTrucks("TRUCK_NO") & "</td>"
If bCloseRow Then response.write "</tr>"
objTrucks.movenext
loop
Thanks for any help.
If there are more rows then four in the recordset you have to make a row more. And if there is less then four you have to insert some empty td tags.
Hope this helps
const iCols=4
dim iCount:iCount=0
if not objTrucks.eof then
response.write "<table>"
Do while not objTrucks.eof
if iCount=0 then response.write "<tr>"
response.write "<td><input type=checkbox name=dno value=" & objTrucks("TRUCK_NO") & objTrucks("TRUCK_NO") & ">" & objTrucks("TRUCK_NO") & "</td>"
objTrucks.movenext
iCount = iCount + 1
if iCount=iCols then
response.write "</tr>"
iCount=0
end if
loop
if iCount>0 then
for i = iCount to iCols-1
response.write "<td></td>"
next
response.write "</tr>"
end if
response.write "</table>"
end if
I would do this using a counter instead of a Boolean flag:
Const numCols = 4
Dim counter
counter = 0
Do While Not objTrucks.EOF
If counter Mod numCols = 0 Then
Response.Write "<tr>"
End If
counter = counter + 1
Response.Write "<td><input type=checkbox name=dno value=" & objTrucks("TRUCK_NO") & objTrucks("TRUCK_NO") & ">" & objTrucks("TRUCK_NO") & "</td>"
If counter Mod numCols = 0 Then
Response.Write "</tr>"
End If
objTrucks.MoveNext
Loop
I have a classic ASP question.
Attempting to do this: the recordset is a simple list of years from 1995 to 2020; and i am trying to make 2010(current year) the default selection in the drop down.
issue: I trying to call a Sub proc in "Response.Write", but it keeps giving me this error:
"Error '800a000d' Type mismatch: 'selectyear' "
Below is the code, the Attempt 1 works with out any problem. But when i move that "if" logic to a sub procedure and call it in the Request.Write, it gives me the error.
Can any one please explain why Attempt1 works and Attempt2 wouldnt.
' Attempt 1:
rsYEAR.Open qYEAR, objconn, 0, 1
response.Write "<tr><td>Year:</td> <td> <select name='theyear' style=""WIDTH: 67px"">"
dim selyr
while not rsYEAR.EOF
if CINT(rsYEAR.fields("year")) = year(now) then
selyr = "selected"
else selyr = ""
end if
Response.Write"<option value='" & rsYEAR.fields("year") & "' "& selyr &" >" & cstr(rsYEAR.Fields("year"))
rsYEAR.MoveNext
wend
response.Write "</select></td></tr>"
rsYEAR.Close
' Attempt 2:
rsYEAR.Open qYEAR, objconn, 0, 1
response.Write "<tr><td>Year:</td> <td> <select name='theyear' style=""WIDTH: 67px"">"
dim selyr2
while not rsYEAR.EOF
Response.Write "<option value='" & rsYEAR.fields("year") & "' " & cstr(selectyear(cint(rsYEAR.fields("year")))) &" >" & cstr(rsYEAR.Fields("year"))
rsYEAR.MoveNext
wend
response.Write "</select></td></tr>"
'close and clean up
rsYEAR.Close
set rsYEAR = nothing
I would greatly appreciate your response.
thank you,
Shiva
I am guessing that cint(rsYEAR.fields("year")) is throwing the error because there is data that cannot be converted to int. I would expect that to happen in both cases though.
You shouldn't need the cstr in cstr(selectyear(cint(rsYEAR.fields("year")))) in the second attempt, as I assume selectyear is already returning a string. Can you show the code for selectyear?
(How has this sat for so long without a correct answer?)
A Sub does not have a value, so you can't Response.Write it. You need to either use a function, or put the Sub call on its own line.
rsYEAR.Open qYEAR, objconn, 0, 1
response.Write "<tr><td>Year:</td><td><select name='theyear' style=""width: 67px"">"
dim y
while not rsYEAR.EOF
y = rsYEAR.fields("year")
Response.Write "<option value='" & y & "'" & IsCurr(y) & ">" & y & "</option>"
rsYEAR.MoveNext
wend
response.Write "</select></td></tr>"
rsYEAR.Close
Function IsCurr(yr)
if Cstr(yr) = Cstr(year(now)) then
IsCurr = " selected"
else
IsCurr = ""
end if
End Function
Using a sub instead of a function, this would become
rsYEAR.Open qYEAR, objconn, 0, 1
response.Write "<tr><td>Year:</td><td><select name='theyear' style=""width: 67px"">"
dim y
while not rsYEAR.EOF
y = rsYEAR.fields("year")
Response.Write "<option value='" & y & "'"
IsCurr y
Response.Write ">" & y & "</option>"
rsYEAR.MoveNext
wend
response.Write "</select></td></tr>"
rsYEAR.Close
Sub IsCurr(yr)
if Cstr(yr) = Cstr(year(now)) then
Response.Write " selected"
end if
End Sub