[soul]

Bir kısmını daha gönderlim;

Record Tree List
Belli bir kayıt dizisinden recursive tree menu veya benzeri şeyler oluşturmaya yarıyor, genelde kullanıma göre özelleştirilmesi gerekebilir.

'// Record Tree List
Function RecTree(byVal SQL, byVal idCol, byVal valCol, byVal parentCol, byVal parentVal, byVal targetHref, byVal subLevel, byVal x,byVal subChar, byRef catCounter)

	Dim Obj, subObj, tmpName, tmpStr, tmpSQL

	tmpSQL = SQL & " WHERE " & parentCol & " = " & parentVal
'	Response.Write SQL : response.end

	getRs Obj, tmpSQL

		'// Loop Records
		While NOT Obj.EOF
			tmpName = "<a href=""" & targetHref & Obj(idCol) & """ title=""" & Obj(valCol) & """>" & Obj(valCol) & "</a>"

			'// Levels
			tmpstr=""
			For i=1 To sublevel
				tmpstr = tmpstr & subChar
			Next
			
			'// Print
			
			'// First Main Cat.
			If catCounter>0 AND sublevel=0 Then Response.Write "<br />"

			'// Main Cats
			If sublevel=0 Then 
				If x Then tmpName = "</td><td valign=""top"">" & tmpName
				tmpName = "<strong>" & tmpName & "</strong>"
			End If

			Response.Write tmpstr & tmpName & "<br />" & vbNewline

			parentVal = Obj(idCol)
			tmpSQL = SQL & " WHERE " & parentCol & " = " & parentVal
			getRs subObj, tmpSQL

			'Response.Write tmpSQL

			'// Call this func.  
			catCounter=catCounter+1
			If RsEmpty(subObj) Then 
				RecTree SQL, idCol, valCol, parentCol, parentVal, targetHref, subLevel+1,x,subChar, catCounter
				'Response.Write "<br>"
			End If
			
			Obj.MoveNext
		Wend
	
	'// Kill
	fmKill Obj

End Function

fmKill
Basit şelkilde bir RS i kapama amacı ile kullanlır

'// fmKill RS
Function fmKill(Obj) '// Close RS
	If isObject(Obj) Then
		Obj.Close
		Set Obj=Nothing
	End If
End Function

fm_NewFile
Text dosyası yoksa oluştur varsa dosyaya ekleme yap

'// New File
Function fm_NewFile(byVal File,byVal Text) 'New File
	Dim FSObj, NewFileObj, GetFObj
	If NOT Instr(File,":") Then File = server.Mappath(File)

	Set FSObj = CreateObject("Scripting.FileSystemObject")
	
	If NOT fm_FileExist(File) Then '// If we don't have
		Set NewFileObj = FSObj.CreateTextFile(File,false,false)
			If Text<>"" Then NewFileObj.Write Text
	Else
		Set GetFObj = FSObj.GetFile(File)
		Set NewFileObj = GetFObj.OpenAsTextStream(8,0)
			If Text<>"" Then NewFileObj.Write Text
		
		Set GetFObj = Nothing
	End If
	
	NewFileObj.Close : Set FSObj=Nothing : Set NewFileObj=Nothing
End Function

fm_GetPath
Dosya Yolunu Al, Verilen stringe göre otomatik olarak server.Mappath ile relative yada absolute path döndürür.

Function fm_getPath(byVal File)
	If NOT Instr(File,":") Then File = server.Mappath(File)
	fm_getPath=File
End Function

fm_hilite
Aranılan kelimeyi renklendir. Google gibi her kelime için farklı renk.
// Comment lı kısım açılırsa farklı renkleri kendi üretir.

'// Hilite Search Texts v1.0
Function fm_hilite(byval alltext,byval word)
	Dim Arrword, i, ArrColorList(15), Color, xx
	Arrword = Split(word,",") '// Make an array from wordlist
	
	'// Generate Color List
'	For xx = 0 to 15 Step 3
'		Color =  "DDFF" & String(2,hex(xx))
'		ArrColorList(Int(xx/3)) = color
'	Next
	
	Dim ArrNewCList, ArrListi
	ArrNewCList = Array ("DF0","DFC","9F0","FCF","9FF","FF0","FF9")

	For i = 0 to Ubound(Arrword)
		word = Trim(Arrword(i))	
		If Instr(alltext,word) > 0 Then
			alltext = Replace(alltext,word,"<span style=""background-color:#" & ArrNewClist(ArrListi mod Ubound(ArrNewCList)) & "; font-weight:bold"">" & word & "</span>")
			ArrListi = ArrListi + 1
		End If
	Next

	fm_hilite = alltext
End Function