[原创] 一些有用的VBS函数（子程序）

function gethtml(byval url,byval t_b)
	Set http = CreateObject("Msxml2.XMLHTTP") 
	with http
		.open "GET",url,false
		.send
		if t_b="text" then
			gethtml=.responsetext
		elseif t_b="binary" then
			gethtml=.responsebody
		end if
	end with
end function
复制代码

sub writeado(target,htmlbody)
	Set ado = createobject("Adodb.Stream")
	Const adTypeBinary = 1
	ado.Type = adTypeBinary
	ado.Open
	ado.Write htmlbody
	ado.SaveToFile target
	ado.Close
End Sub
复制代码

writeado target,gethtml(url,"binary")
复制代码

option explicit
dim myobject
set myobject=setmyobject("[var1=3,var3=[function [] (byval str,byref finding):msgbox str&finding:[]=1:end function],var5=[var10=2,var11=3]]")
msgbox myobject.var5.var11
function setmyobject(byval objectstr)
	if not isclassobject(objectstr) then err.raise
	dim classstr,classname,classinitialize
	classname=createstr(10)
	classstr="class "&classname&vbcrlf
	dim elements:set elements=new arr
	dim thisstr,kcounts:kcounts=0
	dim newstr:newstr=lcase(","&mid(objectstr,2,len(objectstr)-2)&",")
	dim objchar:objchar=toeach(newstr)
	dim i:for i=2 to ubound(objchar)
		if objchar(i)="," and thisstr<>"" and kcounts=0then
			elements.newitem=thisstr
			thisstr=""
		else
			if objchar(i)="[" then kcounts=kcounts+1
			if objchar(i)="]" then kcounts=kcounts-1
			thisstr=thisstr&objchar(i)
		end if
	next
	set objchar=nothing:set kcounts=nothing:set newstr=nothing:set thisstr=nothing
	dim varins:set varins=new arr
	dim element:for each element in elements.tarray
		dim varname:varname=mid(element,1,instr(element,"=")-1)
		dim var:set var=new eachele:var.varname=varname:var.varinit=replace(element,varname&"=","",1,1,0)
		set varins.newitem=var
		classstr=classstr&"public "&varname&vbcrlf
	next
	classstr=classstr&"end class"
	set elements=nothing
	execute(classstr)
	dim myclass:set myclass=eval("new "&classname)
	dim newstr1,functionname
	for each element in varins.tarray
		if isclassobj(element.varinit) then
			if (instr(element.varinit,"function []")=2 or instr(element.varinit,"sub []")=2) then
				functionname=createstr(9)
				newstr1=replace(mid(element.varinit,2,len(element.varinit)-2),"[]",functionname)
				executeglobal(newstr1)
				execute("set myclass."&element.varname&"=getref("&chr(34)&functionname&chr(34)&")")
			else
				dim subobject:set subobject=setmyobject(element.varinit)
				execute("set "&"myclass."&element.varname&"=subobject")
			end if
		else
			execute("myclass."&element.varname&"="&element.varinit)
		end if
	next
	set setmyobject=myclass
end function

class eachele
public varname
public varinit
end class

function isclassobj(byval str)
isclassobj=(mid(str,1,1)="[" and mid(str,len(str),1)="]")
end function

function createstr(length)
dim str,i
randomize
str=""
for i=1 to length
str=str&chr(int(26*rnd)+97)
next
createstr=str
end function

function toeach(str)
dim chars,i
set chars=new arr
chars.newitem=chr(0)
for i=1 to len(str)
chars.newitem=mid(str,i,1)
next
toeach=chars.tarray
end function

class arr
private myarray()
Private Sub Class_Initialize()
redim myarray(-1)
end sub
public property let newitem(item)
redim preserve myarray(ubound(myarray)+1)
myarray(ubound(myarray))=item
end property
public property set newitem(item)
redim preserve myarray(ubound(myarray)+1)
set myarray(ubound(myarray))=item
end property
public property get tarray()
tarray=myarray
end property
end class
复制代码

public function add(byval number1,byval number2)
		len1=len(number1):len2=len(number2)
		char1=stringtochar(number1):char2=stringtochar(number2)
		dim result,remainder
		result="":remainder=0
		do while(len1>=1 or len2>=1)
			dim n1,n2
			if (len1>=1) then
				n1=char1(len1):len1=len1-1
			else
				n1=0
			end if
			if (len2>=1) then
				n2=char2(len2):len2=len2-1
			else
				n2=0
			end if
			num=cdbl(n1)+cdbl(n2)+cdbl(remainder)
			remainder=(num-(num mod 10))/10
			result=result&(num mod 10)
		loop
		if remainder>0 then result=result&remainder
		add=strreverse(result)
	end function
复制代码

public function substract(byval number1,byval number2)'num1 is minuend,num2 is subtrahend
		r_s=numbercompare(number1,number2)
		if r_s=0 then substract=0
		if r_s=-1 then change number1,number2
		len1=len(number1):len2=len(number2)
		char1=stringtochar(number1):char2=stringtochar(number2)
		dim borrow,result
		do while (len1>=1 or len2>=1)
			if (len1>=1) then
				n1=char1(len1):len1=len1-1
			else
				n1=0
			end if
			if (len2>=1) then
				n2=char2(len2):len2=len2-1
			else
				n2=0
			end if
			num=cdbl(n1)-cdbl(n2)+cdbl(borrow)
			if num<0 then 
				borrow=(num-(num mod 10))/10
				result=result&(num+10)
			else
				borrow=0
				result=result&num
			end if
		loop
		for i=2 to len(result)
			if right(result,1)="0" then
				result=mid(result,1,len(result)-1)
			else
				exit for
			end if
		next
		result=strreverse(result)
		if r_s=-1 then result="-"&result
		substract=result
	end function
复制代码

public function multiply(byval n1,byval n2)
		if n1="0" or n2="0" then multiply=0:exit function
		len1=len(n1):len2=len(n2)
		char1=stringtochar(n1):char2=stringtochar(n2)
		dim result:result=""
		for i1=len1 to 1 step -1
			r=""
			for i2=len2 to 1 step -1
				mul=char1(i1)*char2(i2)
				r=add(r,mul&string(len2-i2,"0"))
			next
			result=add(result,r&string(len1-i1,"0"))
		next
		multiply=result
	end function
复制代码

public function numbercompare(byval n1,byval n2)
		s1="+":s2="+"
		if instr(n1,"-")=1 then s1="-":n1=mid(n1,2)
		if instr(n2,"-")=1 then s2="-":n2=mid(n2,2)
		if s1<>s2 then
			if s1="+" then 
				numbercompare=1
			else
				numbercompare=-1
			end if
		else
			dim initresult
			if len(n1)<len(n2) then
				initresult=-1
			elseif len(n1)>len(n2) then
				initresult=1
			else
				c1=stringTochar(n1)
				c2=stringTochar(n2)
				for i=1 to ubound(c1)
					if c1(i)>c2(i) then initresult=1:exit for
					if c1(i)<c2(i) then initresult=-1:exit for
					if i=ubound(c1) then numbercompare=0:exit function
				next
			end if
			if s1="-" then
				initresult=-int(initresult)
			end if
			numbercompare=initresult:exit function
		end if
	end function
复制代码

	private function stringTochar(byval str)
		dim char():redim char(0):char(0)=chr(0)
		for i=1 to len(str)
			redim preserve char(ubound(char)+1)
			char(ubound(char))=mid(str,i,1)
		next
		stringtochar=char
	end function
复制代码

set fso=createobject("scripting.filesystemobject")
dim arr()
redim arr(-1)
getfile "c:\windows",arr
sub getfile(byval path,byref arr)
set mfolder=fso.getfolder(path)
set tfolders=mfolder.subfolders
set tfiles=mfolder.files
for each tfile in tfiles
redim preserve arr(ubound(arr)+1)
arr(ubound(arr))=tfile.path
next
for each tfolder in tfolders
getfile tfolder.path,arr
next
end sub
复制代码