Sitenizdeki aktif kullanicilar
<Object Runat="Server" Scope="application" ID="dOnlineUsers" ProgID="Scripting.Dictionary"></Object>
<SCRIPT LANGUAGE=VBScript RUNAT=Server>
sub Application_OnStart
application("ServerStart") = now
end sub
function Decrypt(sText)
Decrypt = sText
end function
function adZero(sText)
if isNull(sText) then exit function
adZero = string(5 - len(sText), "0") & sText
end function
Sub Session_OnStart
Session.TimeOut = 5
sAktifUsrList = application("AktifUsrList")
sNewUserName = Decrypt(request.cookies("isim")+ request.cookies("soyisim"))
if sNewUserName = "" then sNewUserName = "Ziyaretci-" & AdZero(CInt(application("Ziyaretci")))
sLastActionTime = Time
sUserInfo = sNewUserName & "<|>" & sLastActionTime & "<|>" & sLastPageViewed
dOnlineUsers.Add Session.SessionID, sUserInfo
application.lock
application("AktifUsr") = application("AktifUsr") + 1
application("Ziyaretci") = application("Ziyaretci") + 1
if application("TodaysDate") <> Date() then
application("PageViewsToday") = 0
application("ZiyaretciToday") = 0
end if
application("ZiyaretciToday") = application("ZiyaretciToday") + 1
application("TodaysDate") = Date()
application.unlock
End Sub
Sub Session_OnEnd
on error resume next
dOnlineUsers.Remove Session.SessionID
application.lock
application("AktifUsr") = application("AktifUsr") - 1
application.unlock
End Sub
</SCRIPT>[/B]
En Son 10 Kayıt
<%
'Veritabanına bağlanıyoruz.
set conn=server.createobject("adodb.connection")
conn.open= "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & server.mappath ("db/database.mdb")
'Şimdi Kayıt nesnemizi oluşturuyoruz.
Set rs=server.createobject("adodb.recordset")
'şimdi sql ile sorgu oluşturuyoruz.
sql="select * from tablo where kayit_tarih desc"
'şimdi kayıt nesnemiz olan rs ile tabloyu açtırıyoruz
rs.open sql,conn,1,3
%>
<%
' Şimdi ise sql sorgusu ile aldığımız kayıtların sadece 10 tanesini gösterecek bir döngü yaratıyoruz
for i=1 to 10
%>
<%= rs("kayit_tarih")%> <%= rs("kayit")%>
<% rs.movenext %>
<% next %>
[B]Mail Yolla
Sub SendEmail(strFrom, strTo, strSubject, strBody)
' DB ve email sabitleri
Dim objCDOMail
' email aktif mi
If SEND_EMAIL Then
Set objCDOMail = Server.CreateObject("CDONTS.NewMail")
' obje özellikleri
objCDOMail.From = strFrom
objCDOMail.To = strTo
objCDOMail.Subject = strSubject
objCDOMail.Body = strBody
' mesajı yolla
objCDOMail.Send
Set objCDOMail = Nothing
End If
End Sub
Hazır ASP Kodları
11
●305
- 14-12-2007, 21:13:49Excel'e Databaseden Veri aktarma
<%@ Language=VBScript %>
<%
'sql: kısmına çift tırnak içinde direk sql stringi yaz
'cnnl: database bağlantısı
Function exporttoexcel(FileName,sql,cnnl)
dim iCols
dim i
set rs=server.CreateObject("ADODB.Recordset")
set rs=cnnl.Execute (sql)
iCols = rs.Fields.Count
session("FileName")=cstr(FileName)
set fso = createobject("scripting.filesystemobject")
Set folder = fso.GetFolder("c:\Inetpub\wwwroot\tekintranet\doku man\excel")
Set act = folder.CreateTextFile(""&FileName& "" &".xls", true)
act.WriteLine "<html xmlns:x=""urn:schemas-microsoft-comffice:excel"">"
act.WriteLine "<head>"
act.WriteLine "<!--[if gte mso 9]><xml>"
act.WriteLine "<x:ExcelWorkbook>"
act.WriteLine "<x:ExcelWorksheets>"
act.WriteLine "<x:ExcelWorksheet>"
act.WriteLine "<x:Name>"& "Sheet1" &"</x:Name>"
act.WriteLine "<x:WorksheetOptions>"
act.WriteLine "<xrint>"
act.WriteLine "<x:ValidPrinterInfo/>"
act.WriteLine "</xrint>"
act.WriteLine "</x:WorksheetOptions>"
act.WriteLine "</x:ExcelWorksheet>"
act.WriteLine "</x:ExcelWorksheets>"
act.WriteLine "</x:ExcelWorkbook>"
act.WriteLine "</xml>"
act.WriteLine "<![endif]--> "
act.WriteLine "</head>"
act.WriteLine "<body>"
act.WriteLine "<table>"
act.WriteLine "<tr>"
For i = 0 To iCols - 1
act.WriteLine "<th>"
act.WriteLine "<font face=Arial>"&cstr(rs.Fields.Item(i).Name&"</font>")
act.WriteLine "</th>"
next
act.WriteLine "</tr>"
rs.MoveFirst
i=0
do until rs.EOF
act.WriteLine "<tr>"
For i = 0 To iCols - 1
act.WriteLine "<td>"
if rs.Fields.Item(i)<>"" then
act.WriteLine "<font face=Arial>"&cstr(rs.Fields.Item(i))&"</font>"
end if
act.WriteLine "</td>"
next
act.WriteLine "</tr>"
rs.MoveNext
loop
act.WriteLine "</table>"
act.WriteLine "</body>"
act.WriteLine "</html>"
' close the document
act.close
rs.Close
end function
%> - 14-12-2007, 21:14:27Tavsiye Menüsü Ekleme
<H3>Tavsiye v 1.0</H3>
<%
Dim objCDONTS
Dim strFromName
Dim strFromEmail, strToEmail
Dim strSubject, strBody
Dim strThisPage
Dim strReferringPage
Dim bValidInput
strThisPage = Request.ServerVariables("SCRIPT_NAME")
strReferringPage = Request.ServerVariables("HTTP_REFERER")
' Debugging lines:
'Response.Write strThisPage & "
" & vbCrLf
'Response.Write strReferringPage & "
" & vbCrLf
' Read in and set the initial values of our message parameters
strFromName = Trim(Request.Form("txtFromName"))
strFromEmail = Trim(Request.Form("txtFromEmail"))
strToEmail = Trim(Request.Form("txtToEmail"))
strSubject = "Check out ASP 101!"
strBody = Trim(Request.Form("txtMessage"))
' I set the body message to a message that referenced the page the
' user arrived from. This makes it great if you place a link to it
' from your different articles, but can be weird if people link in
' from other web sites.
If strBody = "" Then
If strReferringPage = "" Or InStr(1, strReferringPage, "www.veritabanim.com", 1) = 0 Then
strBody = ""
strBody = strBody & "Bu site harika bir site.Mutlaka gez..." & vbCrLf
strBody = strBody & vbCrLf
strBody = strBody & " http://www.veritabanim.com" & vbCrLf
Else
strBody = ""
strBody = strBody & "Bu siteyi mutlaka gezmelisin" & vbCrLf
strBody = strBody & vbCrLf
strBody = strBody & " " & strReferringPage & vbCrLf
End If
End If
' Quick validation just to make sure our parameters are somewhat valid
bValidInput = True
bValidInput = bValidInput And strFromName <> ""
bValidInput = bValidInput And IsValidEmail(strFromEmail)
bValidInput = bValidInput And IsValidEmail(strToEmail)
' If valid send email and show thanks, o/w show form
If bValidInput Then
' Set up our email object and send the message
Set objCDONTS = Server.CreateObject("CDONTS.NewMail")
objCDONTS.From = strFromName & " <" & strFromEmail & ">"
objCDONTS.To = strToEmail
objCDONTS.Subject = strSubject
objCDONTS.Body = strBody
objCDONTS.Send
Set objCDONTS = Nothing
' Show our thank you message
ShowThanksMsg
Else
If "http://" & Request.ServerVariables("HTTP_HOST") & strThisPage = strReferringPage Then
Response.Write "Lutfen bos alan birakmayin.Mail adreslerini dogru yazin" & "
" & vbCrLf
End If
' Show our information retrieval form
ShowReferralForm strThisPage, strFromName, strFromEmail, strToEmail, strBody
End If
' End of page logic... subs and functions follow!
%>
<%
' Subroutines and Functions that encapsulate some functionality
' and make the above code easier to write... and read.
' A quick email syntax checker. It's not perfect,
' but it's quick and easy and will catch most of
' the bad addresses than people type in.
Function IsValidEmail(strEmail)
Dim bIsValid
bIsValid = True
If Len(strEmail) < 5 Then
bIsValid = False
Else
If Instr(1, strEmail, " ") <> 0 Then
bIsValid = False
Else
If InStr(1, strEmail, "@", 1) < 2 Then
bIsValid = False
Else
If InStrRev(strEmail, ".") < InStr(1, strEmail, "@", 1) + 2 Then
bIsValid = False
End If
End If
End If
End If
IsValidEmail = bIsValid
End Function
' I made this a function just to get it out of the
' logic and make it easier to read. It just shows the
' form that asks for the input
Sub ShowReferralForm(strPageName, strFromName, strFromEmail, strToEmail, strBody)
' I use script_name so users can rename this script witout having to change the code.
%>
<FORM ACTION="<%= strPageName %>" METHOD="post" name=frmReferral>
<TABLE BORDER="0">
<TR>
<TD VALIGN="top" ALIGN="right">Adiniz:</TD>
<TD><INPUT TYPE="text" NAME="txtFromName" VALUE="" SIZE="30"></TD>
</TR>
<TR>
<TD VALIGN="top" ALIGN="right">Sizin Mailiniz:</TD>
<TD><INPUT TYPE="text" NAME="txtFromEmail" VALUE="" SIZE="30"></TD>
</TR>
<TR>
<TD VALIGN="top" ALIGN="right">Arkadasinizin Maili:</TD>
<TD><INPUT TYPE="text" NAME="txtToEmail" VALUE="" SIZE="30"></TD>
</TR>
<TR>
<TD VALIGN="top" ALIGN="right">Mesaj:</TD>
<TD><TEXTAREA NAME="txtMessage" COLS="50" ROWS="5" WRAP="virtual" READONLY></TEXTAREA>
</TR>
<TR>
<TD></TD>
<TD><INPUT TYPE="reset" VALUE="SİL" name=rstReferral> <INPUT TYPE="submit" VALUE="GÖNDER" name=subReferral></TD>
</TR>
</TABLE>
</FORM>
<%
'
The Message to be sent:</P>
'
Subject: < %= strSubject % ></P>
'
Body: < %= strBody % ></P>
End Sub
' This just shows our thank you message... probably didn't need to
' be a function, but since I made the form one I figured I'd do this
' for consistency.
Sub ShowThanksMsg()
%>
</P>
<%
End Sub
%> - 14-12-2007, 21:16:00Word Dosyalarının Htm Formatına çevirilmesi
--------------------------------------------------------------------------------
'
' Server uzerince ms word bulunmasi gerekir )
' RTF ve DOC formatlari icin calisiyor
' RTFFileNAme ile verilen dosyayi cHtmlFile ile verilen dosyaya kaydeder
' ------------------------------------------------------------------------
Public Function RTF2HTML(cRtfFile, cHtmFile)
Dim wApp
dim fileObj
Set fileObj = CreateObject("Scripting.FileSystemObject")
if fileOBJ.FileExists(cRTFFile) = False Then
RTF2HTML = FALSE
Else
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
wApp.ShowMe()
wApp.Documents.Open(cRTFFile)
wApp.Documents(1).Activate
call wApp.Documents(1).saveas(cHtmFile,8)
call wApp.Documents.close()
wApp.Quit
RTF2HTML = TRUE
End if
Set wApp = Nothing
Set fileObj = Nothing
End Function[/B]
[B]Özel Karakter
<%
For i = 33 to 44
response.write "Chr(" & i & ") = " & Chr(i) & "
"
Next
response.write "Chr(47) = " & Chr(47) & "
"
For i = 58 to 63
response.write "Chr(" & i & ") = " & Chr(i) & "
"
Next
For i = 91 to 94
response.write "Chr(" & i & ") = " & Chr(i) & "
"
Next
response.write "Chr(96) = " & Chr(96) & "
"
response.write "Chr(123) = " & Chr(123) & "
"
%>
<-- Sonuç -->
Chr(33) = !
Chr(34) = "
Chr(35) = #
Chr(36) = $
Chr(37) = %
Chr(38) = &
Chr(39) = '
Chr(40) = (
Chr(41) = )
Chr(42) = *
Chr(43) = +
Chr(44) = ,
Chr(47) = /
Chr(58) = :
Chr(59) = ;
Chr(60) = <
Chr(61) = =
Chr(62) = >
Chr(63) = ?
Chr(91) = [
Chr(92) = \
Chr(93) = ]
Chr(94) = ^
Chr(96) = '
Chr(123) = {
