ASP Fonksiyon Kütüphanesi - 4. Sayfa

PsyChaos · 22.02.2004

Bu fonsiyon ile her türlü mail adresinin doğruluğunu kontrol edebilirsiniz.
Not : Asıl kod ceviz.net forumlarında PHP ile yazılmıştı.. bende ASP diline çevirdim.

Kod:

Public Function EmailControl(myEmail)
	'|
	'| EMail Control
	'| Modified By PsyChaos
	'| A.K.A Semih Turna
	'|
	
		Dim isValidE
		Dim regEx
  
			isValidE = True
			Set regEx = New RegExp
			regEx.IgnoreCase = False
			regEx.Pattern = "^([a-zA-Z0-9_\-\.]+)@((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)$"
			isValidE = regEx.Test(myEmail)
  
		EmailControl = isValidE
	
	End Function

Kullanımı;

Kod:

<%
If EmailControl(Email) = False Then
    			Response.Write "<font size='1' color='#39517B'>»</font> Lütfen Doğru Bir E-mail Adresi Giriniz!<br>"&_
    			"<font size='1' color='#39517B'>»</font> <a href='JavaScript:history.back(1)' class='normal'>Geri Git!</a>"
Else
Response.Write "Email Adresiniz Doğrulandı!"
End If
%>

PsyChaos · 22.02.2004

Uzun yazılarınızı sayfalamak için kullanabileceğiniz bir fonksiyon..
Yazılarınızda bölünmesini istediğiniz yere " " yerleştirmeniz yeterli.

Kod:

<%
'|
'| Makale Paging Function
'| Coded By PsyChaos - A.K.A Semih Turna
'| semih@24saatasp.com
'|

Public Function MakaleBol(Content,Mp)
	'|Gelen Verimizi Aranana Göre Parçalara Bölüyoruz
	
		Searching = "<!--{Cut}-->"
			If inStr(Content,Searching) Then
				strCut = Split(Content,Searching,-1,1)
				n = Mp - 1
				MakaleBol = strCut(n)
			Else
				MakaleBol = Content
			End If
			
	End Function
	
	Public Function MakaleSayfala(Content,Mp,ID)
	'|GelenVerimizi Parcalara Bölerek Parça Sayısına Göre Sayfalandırma Yapıyoruz
	
		Content = Trim(Content)
		Searching = "<!--{Cut}-->"
		
			If inStr(Content,Searching) Then
				strCut = Split(Content,Searching)
				
					If (Len(Content) - inStrRev(Content,Searching) + 1) = Len(Searching) Then
						intStrCut = uBound(strCut) - 1
					Else
						intStrCut = uBound(strCut)
					End If
					
					Response.Write "<font face='verdana' size='1'><b>Gösterilen Sayfa :</b> "& Mp & " <b>- Toplam Sayfa :</b> " & (intStrCut + 1) &"</b><br>"
					
					If Not Mp <= 1 Then Response.Write "<a href='?cmd=MakaleOku&Mp="& (Mp - 1) &"&MakaleID="& ID &"'><font size='2' face='webdings'>3</font></a> " End If
					
						For yz = 0 To intStrCut
							If Mp = (yz + 1) Then
								Response.Write "<b><font size='1'><span style='background-color: #DDE8F9'>"& (yz + 1) &"</span></font></b> "
							Else
								Response.Write "<a href='?cmd=MakaleOku&Mp="& (yz + 1) &"&MakaleID="& ID &"'>"& (yz + 1) &"</a> "
							End If
						Next
						
					If Not Mp >= (intStrCut + 1) Then Response.Write " <a href='?cmd=MakaleOku&Mp="& (Mp + 1) &"&MakaleID="& ID &"'><font size='2' face='webdings'>4</font></a>" End If
						
					Response.Write "</font>"
				Else
					Exit Function
				End If
	
	End Function
%>

Kullanımı;

Kod:

<%
Kullanımı
	Mp = cint(Request("Mp"))
	If Mp = "" OR Mp = 0 Then Mp = cint(1)
	
	deneme = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa<br>sajkdjkasndjadakjsbd <!--{Cut}--> esfdsssssssssssssssssssssssssssssssssssssss <!--{Cut}--> fdsssssssssssssssssssssssssssssssssssssssssssssssss jshutj<!--{Cut}-->asddddddddddddddddddddd <!--{Cut}-->   ds"
	
	Response.Write MakaleBol(deneme,Mp) &"<br>"
	Response.Write MakaleSayfala(deneme,Mp)
%>

Şimdilik bu kadar vakit buldukça sıkça kullandığım fonksiyonları eklemeye devam edeceğim.

cipher · 27.02.2004

Gelen verideki harfleri isteğimize göre büyülten ve küçülten bir fonksiyon.

Fonksiyon;

Kod:

<%
Function TR(gelenveri,islem) 
tempp=gelenveri 

TRdizi1="ABCÇDEFGĞHIİJKLMNOÖPRSŞTUÜVYZWX" 
TRdizi2="abcçdefgğhıijklmnoöprsştuüvyzwx" 

'işlem seçimi.... 
If islem=1 Then 'büyütme işlemi 
     For i=1 To Len(TRdizi1) 
          tempp=Replace(tempp, Mid(TRdizi2,i,1), Mid(TRdizi1,i,1)) 'al birini koy ötekine... 
     Next 

     tempp=UCase(tempp) 
End If 

If islem=2 Then 'küçültme işlemi 
     For i=1 To Len(TRdizi2) 
          tempp=Replace(tempp, Mid(TRdizi1,i,1), Mid(TRdizi2,i,1)) 'al birini koy ötekine... 
     Next 

     tempp=LCase(tempp) 
End If 
TR=tempp 
End Function 
%>

Kullanılış ;

Kod:

<%
'1 Gelen verileri büyültür.
'2 Gelen verileri küçültür.
strGelen = Request.form ("txtVeri")
Response.Write TR(strGelen,1)
%>

scriptMan · 27.02.2004

Merhaba, benimde katkım bulunsun istedim. Aşağıdaki class sayesinde bir array' de tutulan istediğiniz her türlü veriyi sayfalayabilirsiniz. Tek yapmanız gereken recPerPage degiskenine bir sayfada görünmesini istediğiniz veri adedini girmek ve DoPaging fonksiyonunu çağırmak.

Kod:

Class S2Paging

	Public recPerPage
	
	Private Function ParseValues(valueArray,rec_count,byRef carry)
		If Not IsArray(valueArray) Or Not IsNumeric(rec_count) Then 'Eger array verilmedi ise cik
			ParseValues = 0
			Exit Function
		End If
		If UBound(valueArray) < rec_count Then
			carry = 0
			ParseValues = 1
		Else
			carry = UBound(valueArray) Mod rec_count 'artan deger adedi ;)
			ParseValues = Fix(UBound(valueArray)/rec_count) 'sayfa adedi..
		End If
	End Function
''''''''''''''''''''''''''''''''''
	Public Function DoPaging(valueArray,byRef referArray,byRef carry_out)
		max_val = recPerPage 'bir sayfada görünecek kayit sayisi burada!!!
		sayfa = ParseValues(valueArray,max_val,v_carry)
		If sayfa = 0 Then Exit Function
		ReDim cache(sayfa,max_val-1)
		st_val = 0
		ff = 0
		For i=0 To sayfa-1
			For k = st_val To (st_val+max_val)-1
				On Error Resume Next
				If ff > max_val-1 Then ff = 0
				If v_carry <> 0 Then 'fazladan deger var
					ReDim l_value(v_carry-1)
					a_start = UBound(valueArray)-v_carry
					For l=0 To v_carry-1
						l_value(l) = valueArray(a_start+l)
					Next
				End If
				cache(i,ff) = valueArray(k)
				ff = ff+1
				st_val = st_val+1
			Next
		Next
		referArray = cache
		carry_out = l_value
	End Function
End Class

DoPaging fonksiyonuna referans olarak verdiğiniz array değişkenlerinden ilki (referArray) fazlalık olmadan (bölme işlemi ile ilgili) kalan sayfalanmış verileri tutar mesela referArray(0,0) ilk sayfanın ilk verisi

carry_out dizisi ise eğer bölme işlemi fazlalıklı çıkmış ise artan verileri saklar. Aynı yöntem ile verilere erişilebilir. Çalıştırması biraz karışık ama çalışınca gayet sağlam çalışıyor. Bu yöntemle iki site çalıştırıyorum

PsyChaos · 12.05.2004

Bir Array Collection Listesi. PHP den esinlendim. PHP de arraylar ile yapılabilecekleri bu class ile ASP ilede yapabileceksiniz. Artık kod yazmaya son

Kod:

<script language="VBScript" runat="server">
'************************
'* Array Collection		*
'* Coded by PsyChaos	*
'* A.K.A Semih Turna	*
'* 18.04.2004 18:15		*
'* semih@maxiasp.com	*
'************************
	
		Class ArrayCollection
			Public arrContent
			Private objArr
			
			Private Sub Class_Initialize
				Set objArr = server.CreateObject("Scripting.Dictionary")
					objArr.CompareMode = 0
					objArr.RemoveAll
			End Sub
			
			Private Sub Class_Terminate
				If IsObject(objArr) Then Set objArr = Nothing
			End Sub
			
			Private Property Get sizeof
			'| Dizi Boyutunu Alır			
				If Not IsArray(arrContent) Then Exit Property
					On Error Resume Next
					ubnd = uBound(arrContent)
						If Err Then
							sizeof = - 1 : Exit Property
						End If
					sizeof =  ubnd
			End Property
						
			Public Function in_array(arrValue)
			'| Dizi İçinde Verilen Değeri Aramaya Yarar
				If Not IsArray(arrContent) OR IsNull(arrValue) Then Exit Function
					For psy = 0 To sizeof
						If arrContent(psy) = arrValue Then
							in_array = True : Exit Function
						Else
							in_array = False
						End If
					Next
			End Function
			
			Public Function array_push(arrValue)
			'| Dizi Sonuna Verilen Değeri Ekler
				If Not IsArray(arrContent) OR IsNull(arrValue) Then Exit Function
					ReDim Preserve arrContent(sizeof+1)
						arrContent(sizeof) = arrValue
					array_push = sizeof
			End Function
			
			Public Function array_unshift(arrValue)
			'| Dizinin Başına Eleman Eklemek İçin Kullanılır
				If Not IsArray(arrContent) OR IsNull(arrValue) Then Exit Function
					Dim newArr() : ReDim newArr(0) : newArr(0) = arrValue
						For psy = 1 To (sizeof+1)
							ReDim Preserve newArr(sizeof+1)
							newArr(psy) = arrContent(psy-1)
						Next
							arrContent = newArr
					array_unshift = sizeof
			End Function
			
			Public Property Get array_pop
			'| Dizinin Sonundan Eleman Silmek İçin Kullanılır
				If Not IsArray(arrContent) Then Exit Property
					ReDim Preserve arrContent(sizeof-1)
					array_pop = sizeof 'arrContent(sizeof)
			End Property
			
			Public Property Get array_shift
			'| Dizinin Başından Eleman Silmek İçin Kullanılır
				If Not IsArray(arrContent) Then Exit Property
					For psy = 1 To sizeof
						arrContent(psy-1) = arrContent(psy)
					Next
					ReDim Preserve arrContent(sizeof-1)
				array_shift = sizeof
			End Property
			
			Public Function array_removeat(arrValue)
			'| Diziden Belirtilen Elemanı Siler
				If Not IsArray(arrContent) OR IsNull(arrValue) Then Exit Function
					Dim newArr() : j = 0 : ReDim newArr(sizeof-1)
						For psy = 0 To sizeof
							If arrContent(psy) <> arrValue Then
								newArr(j) = arrContent(psy)
								j = j + 1
							End If
						Next
						arrContent = newArr
				array_removeat = sizeof
			End Function
			
			Public Function array_mid(number_one,number_two)
			'| Bir Dizinin Belirlenen Bölümlerini Gösterir.ASP`de String Fonksiyonlarda Kullanılan Mid() Fonksiyonuna Benzer
				If Not IsArray(arrContent) OR Not IsNumeric(number_one) OR Not IsNumeric(number_two) Then Exit Function
				If number_one <= 0 OR number_one > sizeof OR number_two <= 0 OR number_two > sizeof Then Exit Function
					Dim newArr() : j = -1
					For psy = number_one-1 To number_two
					j = j + 1 : Redim Preserve newArr(j)
						newArr(j) = arrContent(psy)
					Next
					arrContent = newArr
				array_slice = sizeof
			End Function
			
			Public Property Get array_reverse
			'| Dizi İçeriğini Tersine Çevirir
				If Not IsArray(arrContent) Then Exit Property
					Dim newArr() : ReDim newArr(sizeof)
						For psy  = 0 To sizeof
							newArr(sizeof-psy) = arrContent(psy)
						Next
						arrContent = newArr
					array_reverse = sizeof
			End Property
			
			Public Property Get array_shuffle
			'| Dizi İçeriğini Karıştırır
				If Not IsArray(arrContent) Then Exit Property
				newArr = Array(0) : Randomize
					For psy = 0 To sizeof
					x = Int(sizeof * Rnd) 'Rasgele Sayı Seç
						newArr(uBound(newArr)) = arrContent(x) 'Tampon Dizinin Geçerli Elemanına Ana Dizinin Bulunan Elemanını Ekle
						Redim Preserve newArr(uBound(newArr) + 1) 'Tampon Dizinin Eleman Sayısı Bir Arttır
						arrContent(x) = arrContent(sizeof) 'Ana Dizinin Bulunan Elemanını En Sondakiyle Değiştir
						ReDim Preserve arrContent(sizeof-1) 'En Sondaki Elemanı Yoket
					Next
					ReDim Preserve newArr(uBound(newArr)-1)
					arrContent = newArr
				array_shuffle = sizeof
			End Property
			
			Public Property Get array_unique
			'| Dizide Tekrarlanan Elemanları Siler
				If Not IsArray(arrContent) Then Exit Property
					For Each psy In arrContent
						If Not objArr.Exists(psy) Then
							objArr.Add psy , psy
						End If
					Next
					arrContent = objArr.Keys
					array_unique = sizeof
			End Property
			
			Public Function array_diff(arr_two)
			'| 2 Dizi Arasındaki Farkları Bulur
				If Not IsArray(arrContent) OR Not IsArray(arr_two) Then Exit Function
					newArr = Array(0)
					For psy = 0 To sizeof
						For x = 0 To uBound(arr_two)
							If arrContent(psy) = arr_two(x) Then
								arrContent(psy) = ""
								arr_two(x) = ""
							End If
						Next
					Next
					For i = 0 To sizeof
						If arrContent(i) <> "" Then
							newArr(uBound(newArr)) = arrContent(i) : ReDim Preserve newArr(uBound(newArr) + 1)
						End If
					Next
					For y = 0 To uBound(arr_two)
						If arr_two(y) <> "" Then
							newArr(uBound(newArr)) = arr_two(y) : ReDim Preserve newArr(uBound(newArr) + 1)
						End If
					Next
					ReDim Preserve newArr(uBound(newArr)-1)
					arrContent = newArr
				array_diff = sizeof
			End Function
			
			Public Function array_intersect(arr_two)
			'| 2 Dizi Arasındaki Benzerlikleri Bulur
				If Not IsArray(arrContent) OR Not IsArray(arr_two) Then Exit Function
				Dim newArr() : i = -1
					For psy = 0 To sizeof
						For x = 0 To uBound(arr_two)
							If arrContent(psy) = arr_two(x) Then
								i = i + 1 : ReDim Preserve newArr(i)
								newArr(i) = arrContent(psy)
							End If
						Next
					Next
					arrContent = newArr
				array_intersect = sizeof
			End Function
			
			Public Property Get array_asc
			'| Verilen Dizi Değişkenini [A-Z] Biçinde Dizer
				If Not IsArray(arrContent) Then Exit Property
					For psy = 0 To sizeof
						For x = psy To sizeof
							If arrContent(psy) > arrContent(x) Then
								newArr = arrContent(psy)
								arrContent(psy) = arrContent(x)
								arrContent(x) = newArr
							End If
						Next
					Next
				array_asc = sizeof
			End Property
			
			Public Property Get array_desc
			'| Verilen Dizi Değişkenini [Z-A] Biçinde Dizer
				If Not IsArray(arrContent) Then Exit Property
					For psy = 0 To sizeof
						For x = psy To sizeof
							If arrContent(psy) < arrContent(x) Then
								newArr = arrContent(psy)
								arrContent(psy) = arrContent(x)
								arrContent(x) = newArr
							End If
						Next
					Next
				array_desc = sizeof
			End Property
			
			Public Property Get array_sum
			'| Dizide Bulunan Elemanların Toplamını Alır
				If Not IsArray(arrContent) Then Exit Property
					For psy = 0 To sizeof
						x = x + arrContent(psy)
					Next
				array_sum = x
			End Property
			
			Public Property Get array_count_values
			'| Bir Elemanın Dizide Kaç Defa Tekrarlandığını Bulur
				If Not IsArray(arrContent) Then Exit Property
					newArr = Array(0)
						For psy = 0 To sizeof
						Counter = 1
							For x = 0 To sizeof
								If arrContent(psy) = arrContent(x) Then
									Redim Preserve newarr(psy+1)
									newArr(psy) = arrContent(psy) &" ("& Counter &")"
									Counter = Counter + 1
								End If
							Next
						Next
						ReDim Preserve newArr(uBound(newArr) - 1)
						arrContent = newArr
						array_unique
					array_count_values = sizeof
			End Property
			
			Public Property Get array_list
				If Not IsArray(arrContent) Then Exit Property
					For psy = 0 To sizeof
						arr = arr &"=> ["& psy &"] "& arrContent(psy) &"<br>"& vbCrlf
					Next
				array_list = "Array<br>(<br>"& arr &")"
			End Property
			
		End Class
</script>

Kullanımı

Kod:

<%
	strArray = Array("Elma","Armut","Muz","Erik","Muz")
	strArray_1 = Array("Muz","Çilek","Erik")
	
	Set t = New ArrayCollection
		't.arrContent = strArray
		't.array_push("Kayısı")
		't.array_unshift("Kayısı")
		't.array_pop
		't.array_shift
		't.array_removeat("Armut")
		't.array_reverse
		't.array_shuffle
		't.array_unique
		't.array_diff(strArray_1)
		't.array_intersect(strArray_1)
		't.array_asc
		't.array_desc
		't.array_sum
		't.array_count_values
		't.array_mid 3,4
		'Response.Write t.array_list
	Set t = Nothing
%>

fonksiyonlar hakkında gerekli açıklamalar bulunmaktadır.. Daha fazla bilgi için imzamda bulunan linkten yararlanabilirsiniz

PsyChaos · 12.05.2004

Bu da ben en son yazdığım bir takvim uygulaması. güle güle kullanın

Çalışan hali için : http://www.clanbtk.com/class/clsCalendar.asp

Kod:

<script language="VBScript" runat="server">
	'########################
	'# PsyChaos - Takvim	#
	'# Coded By PysChaos	#
	'# A.K.A Semih Turna	#
	'# semih@maxiasp.com	#
	'# 07.05.2004 21:30		#
	'########################

Class clsCalendar
	Public intDate		'|Dışardan Gelecek Zaman
	Public strPage		'|Gidilmesini İstediğiniz Sayfa
	Public MinYear		'|Gidilebilecek En Düşük Yıl 
	Public MaxYear		'|Gidilebilecek En Yüksek Yıl
	
		Private Property Get DayConfig
			Select Case Month(intDate)
				Case 1, 3, 5, 7, 8, 10, 12
					DayConfig = 31
				Case 4, 6, 9, 11
					DayConfig = 30
				Case 2
					If IsDate("29.02."& Year(intDate)) Then
						DayConfig = 29
					Else
						DayConfig = 28
					End If
			End Select
		End Property
		
		Private Property Get WeekConfig
			intWeek = DateAdd("d", -(Day(intDate) - 1), intDate)
			WeekConfig = Weekday(intWeek-1)
		End Property
		
		Private Function Back
			Back = DateAdd("m", -1, intDate)
		End Function
		
		Private Function Forward
			Forward = DateAdd("m", 1, intDate)
		End Function
		
		Public Sub CreateCalendar()
			If Year(intDate) < MinYear OR Year(intDate) > MaxYear Then
				Response.Write "<font face='verdana' size='1'>Bu Zamana Gitmeniz Mümkün Değil!</font>" : Exit Sub
			Else
			
			Dim confDay, confWeek
				confDay 	= DayConfig
				confWeek 	= WeekConfig
				
					With Response
						.Write "<table border='0' width='10%' id='table1' cellspacing='0' cellpadding='0' bgcolor='#003399'>"& vbCrlf
						.Write "	<tr>"& vbCrlf
						.Write "		<td>"& vbCrlf
						.Write "		<table border='0' width='100%' id='table2' cellspacing='1' cellpadding='2'>"& vbCrlf
						.Write "			<tr>"& vbCrlf
						.Write "				<td width='20%' bgcolor='#0099FF'>"& vbCrlf
						.Write "				<p align='center'><font size='1' color='#FFFFFF'><b><a href='"& strPage &"?Tarih="& Back &"'>&lt;&lt;</a></b></font></td>"& vbCrlf
						.Write "				<td width='60%' bgcolor='#0099FF'><p align='center'><font size='1' face='Arial'>"& MonthName(Month(intDate)) &" - "& Year(intDate) &"</font></td>"& vbCrlf
						.Write "				<td width='20%' bgcolor='#0099FF'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' color='#FFFFFF'><b><a href='"& strPage &"?Tarih="& Forward &"'>&gt;&gt;</a></b></font></td>"& vbCrlf
						.Write "			</tr>"& vbCrlf
						.Write "		</table>"& vbCrlf
						.Write "		</td>"& vbCrlf
						.Write "	</tr>"& vbCrlf
						.Write "	<tr>"& vbCrlf
						.Write "		<td>"& vbCrlf
						.Write "		<table border='0' width='100%' id='table3' cellspacing='1' cellpadding='2'>"& vbCrlf
						.Write "			<tr>"& vbCrlf
						.Write "				<td bgcolor='#B0D8FF' width='14%'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' face='Arial'>Pt</font></b></td>"& vbCrlf
						.Write "				<td bgcolor='#B0D8FF' width='14%'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' face='Arial'>Sa</font></b></td>"& vbCrlf
						.Write "				<td bgcolor='#B0D8FF' width='14%'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' face='Arial'>Ça</font></b></td>"& vbCrlf
						.Write "				<td bgcolor='#B0D8FF' width='14%'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' face='Arial'>Pe</font></b></td>"& vbCrlf
						.Write "				<td bgcolor='#B0D8FF' width='14%'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' face='Arial'>Cu</font></b></td>"& vbCrlf
						.Write "				<td bgcolor='#B0D8FF' width='14%'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' face='Arial'>Ct</font></b></td>"& vbCrlf
						.Write "				<td bgcolor='#B0D8FF' width='14%'>"& vbCrlf
						.Write "				<p align='center'><b><font size='1' face='Arial'>Pz</font></b></td>"& vbCrlf
						.Write "			</tr>"& vbCrlf
							If Not ConfWeek = 1 Then
								intPosition = 1
								.Write "			<tr>"& vbCrlf
								While intPosition < confWeek
								.Write "				<td bgcolor='#E6F2FF' width='14%' align='center'><font size='1' face='Arial'>X</font></td>"& vbCrlf
								intPosition = intPosition + 1
								Wend
							End If
								
								intDay = 1
								intPosition = confWeek
								While intDay <= confDay
									If intPosition = 1 Then : .Write "			<tr>"& vbCrlf
									If intDay = Day(intDate) Then
										.Write "				<td bgcolor='#FFCCFF' width='14%' align='center'><font size='1' face='Arial'><b><a href='"& strPage &"'>"& intDay &"</a></b></font></td>"& vbCrlf
									Else
										.Write "				<td bgcolor='#FFFFFF' width='14%' align='center'><font size='1' face='Arial'><b><a href='"& strPage &"'>"& intDay &"</a></b></font></td>"& vbCrlf
									End If
									If intPosition = 7 Then : .Write "			</tr>"& vbCrlf : intPosition = 0
								intDay = intDay + 1 : intPosition = intPosition + 1
								Wend
								
								If Not intPosition = 1 Then
									While intPosition <= 7
									.Write "				<td bgcolor='#E6F2FF' width='14%' align='center'><font size='1' face='Arial'>X</font></td>"& vbCrlf
									intPosition = intPosition + 1
									Wend
								.Write "			</tr>"& vbCrlf
								End If
								
						.Write "		</table>"& vbCrlf
						.Write "		</td>"& vbCrlf
						.Write "	</tr>"& vbCrlf
						.Write "</table>"& vbCrlf
					End With
					
			End If '|Yıl Kontrolü Bitti
		End Sub
		
		Public Sub Stye
			With Response
				.Write "<style>"& vbCrlf
				.Write "A:link {color: #3366CC; text-decoration: none}"& vbCrlf
				.Write "A:active  {color: #3366CC; text-decoration: none}"& vbCrlf
				.Write "A:visited {color: #3366CC; text-decoration: none}"& vbCrlf
				.Write "A:hover {color: #3366CC; text-decoration: underline}"& vbCrlf
				.Write "</style>"& vbCrlf
			End With
		End Sub
		
End Class
	
</script>

Kullanımı

Kod:

<%
	If Request.QueryString("Tarih") = "" Then
		Tarih = CDate(Date)
	Else
		Tarih = CDate(Request.QueryString("Tarih"))
	End If

	Set Calendar = New clsCalendar
		With Calendar
			.Stye
			.MinYear = 2004
			.MaxYear = 2005
			.intDate = Tarih
			.strPage = "clsCalendar.ASP"
			.CreateCalendar()
		End With
	Set Calendar = Nothing
%>

PsyChaos · 12.05.2004

Bu class ise bağlantı işlemlerinde kolaylık sağlaması açısından yazıldı

Kod:

<script language="VBScript" runat="server">
'************************
'* Conntection Object	*
'* Coded by PsyChaos	*
'* A.K.A Semih Turna	*
'* 22.04.2004 09:30 	*
'* semih@maxiasp.com	*
'************************

	Class clsTFConnection
		Public vtType, vtPath
		Public SQLServerName, SQLUserID, SQLPwd, SQLDBName
		Private objConn, objName
			
			Private Sub Class_Initialize
				Set objConn = server.CreateObject("ADODB.Connection")
			End Sub
			
			Private Sub Class_Terminate
				If IsObject(objConn) Then objConn.Close : Set objConn = Nothing
			End Sub
			
			Public Function openDB
				If Not IsNumeric(vtType) Then
					ErrMsg "Veritabanı Türü Sayı Olmalıdır!" : Response.End
				Else
					Select Case vtType
						Case 1
							If vtPath = "" OR IsNull(vtPath) OR IsEmpty(vtPath) Then
								ErrMsg "Lütfen Veritabanı Yolunu Girin!" : Response.End
							Else
								objConn.open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & server.Mappath(vtPath)
							End If
						Case 2
							If SQLServerName = "" OR IsNull(SQLServerName) OR IsEmpty(SQLServerName) Then
								ErrMsg "Lütfen SQL server Adını Giriniz!" : Response.End
							ElseIf SQLUserID = "" OR IsNull(SQLUserID) OR IsEmpty(SQLUserID) Then
								ErrMsg "Lütfen SQL server Kullanıcı Adınızı Giriniz!" : Response.End
							ElseIf SQLPwd = "" OR IsNull(SQLPwd) OR IsEmpty(SQLPwd) Then
								ErrMsg "Lütfen SQL server Parolanızı Giriniz!" : Response.End
							ElseIf SQLDBName = "" OR IsNull(SQLDBName) OR IsEmpty(SQLDBName) Then
								ErrMsg "Lütfen Veritabanı Adını Giriniz" : Response.End
							Else
								objConn.open "Driver={SQL server}; server="& SQLServerName &"; Uid="& SQLUserID &"; Pwd="& SQLPwd &"; Database="& SQLDBName
							End If
						Case Else
							ErrMsg "Girilen Veritabanı Türü Bulunamadı!" : Response.End
					End Select
				End If
			End Function
			
			Public Property Set RSName(Data)
				Set objName = Data
			End Property
			
			Public Property Get RSName
				Set RSName = objName
			End Property
			
			Public Function SQLCode(SQL)
				RSName.open(SQL),objConn,1,3
			End Function
			
			Private Sub ErrMsg(Msg)
				Response.Write "<font face='verdana'><font size='3' color='#ff0000'><b>Hata :</b></font>"&_
							   "<br><font size='2'>• "& Msg &"</font></font>"
			End Sub
	End Class
</script>

Kullanımı :

Kod:

<%
	Set tfConn = New clsTFConnection
		tfConn.vtType = 1
		tfConn.vtPath = "../db/dbadi.mdb"
		tfConn.openDB
		Set tfConn.RSName = server.CreateObject("ADODB.RecordSet")
		Set RS = tfConn.RSName
		tfConn.SQLCode("Select * From tblKategori")
		If RS.EOF Then
			Response.Write "Yok"
		Else
			Do Until RS.EOF
				Response.Write "<b>"& RS("Sira") &".</b> "& RS("KategoriAdi") &"<br>"& vbCrlf
			RS.MoveNext
			Loop
		End If
		
		RS.Close : Set RS = Nothing
	Set tfConn = Nothing
%>

Daha fazla bilgi için imzamda bulunan Class işlemleri konularına bakabilirsiniz.

PsyChaos · 12.05.2004

Buda değişik bir klasör listeleme denemesi.. oldukça başarılı

Kod:

<%
	'|==================================|'
	'| PsyChaos - Directory List v1.0b	|'
	'| Coded By PsyChaos				|'
	'| A.K.A Semih Turna				|'
	'| 04.04.2004 14:52					|'
	'|==================================|'
	
		Class DL
			Private objFSO, objFolder
			Private rsDirectory
			Private Msg
			Public strLocation
			
				Private Sub Class_Initialize()
					Const adInteger = 3
					Const adVarChar = 200
					Const adBoolean = 11
					Const adDBTimeStamp = 135
					
					Set objFSO = server.CreateObject("Scripting.FileSystemObject")
					Set rsDirectory = server.CreateObject("ADODB.RecordSet")
						With rsDirectory
							.Fields.Append "Name", adVarChar, 50
							.Fields.Append "Type", adBoolean
							.Fields.Append "Location", adVarChar, 100
							.Fields.Append "Size", adInteger
							.Fields.Append "DateLastModified", adDBTimeStamp
							.open
						End With
				End Sub
				
				Private Sub Class_Terminate()
					If IsObject(objFSO) Then Set objFSO = Nothing
					If IsObject(rsDirectory) Then rsDirectory.Close  : Set rsDirectory = Nothing
				End Sub
				
					Public Sub AddItem
							If objFSO.FolderExists(strLocation) = False Then
								ErrMsg "Girmiş Olduğunuz ""<b>"& strLocation &"</b>"" Adlı Yol Bulunamadı!"
							Else
								Set objFolder = objFSO.GetFolder(strLocation)
								For Each strFolder In objFolder.SubFolders
									With rsDirectory
										.AddNew
											.Fields("Name") = strFolder.Name
											.Fields("Type") = 0
											.Fields("Location") = EditUrl(Session("Path") &"\"& strFolder.Name)
											.Fields("Size") = strFolder.Size
											.Fields("DateLastModified") = strFolder.DateLastModified
										.Update
									End With
								Next
								For Each strFile In objFolder.Files
									With rsDirectory
										.AddNew
											.Fields("Name") = strFile.Name
											.Fields("Type") = 1
											.Fields("Location") = EditUrl(Session("Path") &"\"& strFile.Name)
											.Fields("Size") = strFile.Size
											.Fields("DateLastModified") = strFile.DateLastModified
										.Update
									End With
								Next
							End If
					End Sub
					
					Public Sub DirectoryList
					If objFSO.FolderExists(strLocation) = True Then
						If objFolder.SubFolders.Count > 0 Then strTotalFolder = objFolder.SubFolders.Count
						strTotalFile = objFolder.Files.Count
						strPath = objFolder.ShortPath
						strFolderSize = FileSize(objFolder.Size)
					End If
					
						If rsDirectory.EOF Then
							ErrMsg "Kayıt Bulunmamaktadır!"
						Else
							With Response
								.Write "<div align='center'>"& vbCrlf
								.Write "	<table border='0' width='50%' id='table1' cellspacing='1' cellpadding='2'>"& vbCrlf
								.Write "		<tr>"& vbCrlf
								.Write "			<td width='5%' bgcolor='#000066'>"& vbCrlf
								.Write "			<p align='center'><b><font size='2' face='Verdana' color='#FFFFFF'>#</font></b></td>"& vbCrlf
								.Write "			<td width='60%' bgcolor='#000066'><b>"& vbCrlf
								.Write "			<font size='2' face='Verdana' color='#FFFFFF'>Ad</font></b></td>"& vbCrlf
								.Write "			<td width='15%' bgcolor='#000066'>"& vbCrlf
								.Write "			<p align='center'><b><font size='2' face='Verdana' color='#FFFFFF'>Boyut</font></b></td>"& vbCrlf
								.Write "			<td width='20%' bgcolor='#000066'>"& vbCrlf
								.Write "			<p align='center'><b><font size='2' face='Verdana' color='#FFFFFF'>Değiştirilme Tarihi</font></b></td>"& vbCrlf
								.Write "		</tr>"& vbCrlf
								.Write "		<tr><td colspan='5'><font face='Verdana' size='1'><a href='dlist.ASP?Path="& Left(Session("Path"),instrRev(Session("Path"),"\")-1) &"'>Üst Klasör</a></font></td></tr>"
						rsDirectory.MoveFirst
						Do While Not rsDirectory.EOF
						If rsDirectory.Fields("Type").Value = 0 Then
							strImage = "<img border='0' src='img/folder.gif' width='16' height='16'>"
							strName = "<a href='dlist.ASP?Path="& rsDirectory.Fields("Location").Value &"'><b>"& rsDirectory.Fields("Name").Value &"</b></a>"
						Else
							strImage = "<img border='0' src='img/file.gif' width='16' height='16'>"
							strName = "<a target='_blank' href='"& rsDirectory.Fields("Location").Value &"'>"& rsDirectory.Fields("Name").Value &"</a>"
						End If
						
								.Write "		<tr>"& vbCrlf
								.Write "			<td width='5%'><p align='center'>"& strImage &"</td>"& vbCrlf
								.Write "			<td width='60%' bgcolor='#F1F1F1'><font size='1' face='Verdana'>"& strName &"</font></td>"& vbCrlf
								.Write "			<td width='15%'>"& vbCrlf
								.Write "			<p align='center'><font size='1' face='Verdana'>"& FileSize(rsDirectory.Fields("Size").Value) &"</font></td>"& vbCrlf
								.Write "			<td width='20%' bgcolor='#F1F1F1'>"& vbCrlf
								.Write "			<p align='center'><font size='1' face='Verdana'>"& rsDirectory.Fields("DateLastModified").Value &"</font></td>"& vbCrlf
								.Write "		</tr>"& vbCrlf
						rsDirectory.MoveNext
						Loop
								.Write "		<tr>"& vbCrlf
								.Write "			<td colspan='4' bgcolor='#000066'>"& vbCrlf
								.Write "			<p align='center'><font color='#FFFFFF' face='Verdana' size='1'>Bunulunduğunuz klasör <b>"& strPath &"</b> - Bu klasörde <b>"& strTotalFile &" dosya</b>, <b>"& strTotalFolder &" alt klasör</b> bulunmaktadır.<br>Bulunduğunuz klasörün boyutu <b>"& strFolderSize &"</b></font></td>"& vbCrlf
								.Write "		</tr>"& vbCrlf
								.Write "	</table>"& vbCrlf
								.Write "</div>"& vbCrlf
							End With
						End If
					End Sub
					
					Private Function FileSize(ItemSize)
						If ItemSize >= 1073741824 Then
							ItemSize = FormatNumber((ItemSize/1073741824),2) &" GB"
						ElseIf ItemSize >= 1048576 Then
							ItemSize = FormatNumber((ItemSize/1048576),2) &" MB"
						ElseIf ItemSize >= 1024 Then
							ItemSize = FormatNumber((ItemSize/1024),2) &" KB"
						ElseIf ItemSize >= 0 Then
							ItemSize = ItemSize &" byte"
						Else
							ItemSize = "0 byte"
						End If
		
						FileSize = ItemSize
					End Function
					
					Private Function EditUrl(Url)
						If Instr(1,Url, "\\",1) <> 0 Then Url = Replace(Url,"\\","\")
						EditUrl = Url
					End Function
					
					Public Sub ErrMsg(Msg)
						Response.Write "<font face='verdana' size='2'><font color='#FF0000'><b>Hata :</b></font> "& Msg &"</font><br>"& vbCrlf
					End Sub
				
		End Class
%>

Kullanimi

Kod:

<%
Session("Path") = Replace(Request.QueryString("Path"),"/","\")
		If Session("Path") = "" Then Response.Redirect "?Path=.\"
		If Session("Path") = "." Then Response.Redirect "?Path=..\"
		If Session("Path") = ".." Then Session("Path") = Session("Path") &"\"
		
		Set DList = New DL
			DList.strLocation = server.MapPath(Session("Path"))
			DList.AddItem
			DList.DirectoryList
		Set DList = Nothing
		
					With Response
						.Write "<br>"& vbCrlf
						.Write "<div align='center'>"
						.Write "<font face='verdana' size='1'><b>PsyChaos - Directory List v1.0b</b><br>Coded By <a href='mailto:semih@maxiasp.com'>PsyChaos</a>"
						.Write "</div>"
					End With
%>