Board logo

标题: [原创] 一些有用的VBS函数(子程序) [打印本页]

作者: jyswjjgdwtdtj    时间: 2023-2-10 11:36     标题: 一些有用的VBS函数(子程序)

下载网页
  1. function gethtml(byval url,byval t_b)
  2. Set http = CreateObject("Msxml2.XMLHTTP")
  3. with http
  4. .open "GET",url,false
  5. .send
  6. if t_b="text" then
  7. gethtml=.responsetext
  8. elseif t_b="binary" then
  9. gethtml=.responsebody
  10. end if
  11. end with
  12. end function
复制代码
配套的把二进制数据写入的:
  1. sub writeado(target,htmlbody)
  2. Set ado = createobject("Adodb.Stream")
  3. Const adTypeBinary = 1
  4. ado.Type = adTypeBinary
  5. ado.Open
  6. ado.Write htmlbody
  7. ado.SaveToFile target
  8. ado.Close
  9. End Sub
复制代码
如下使用
  1. writeado target,gethtml(url,"binary")
复制代码
以前做的 创建类似于JavaScript对象的树状结构
  1. option explicit
  2. dim myobject
  3. set myobject=setmyobject("[var1=3,var3=[function [] (byval str,byref finding):msgbox str&finding:[]=1:end function],var5=[var10=2,var11=3]]")
  4. msgbox myobject.var5.var11
  5. function setmyobject(byval objectstr)
  6. if not isclassobject(objectstr) then err.raise
  7. dim classstr,classname,classinitialize
  8. classname=createstr(10)
  9. classstr="class "&classname&vbcrlf
  10. dim elements:set elements=new arr
  11. dim thisstr,kcounts:kcounts=0
  12. dim newstr:newstr=lcase(","&mid(objectstr,2,len(objectstr)-2)&",")
  13. dim objchar:objchar=toeach(newstr)
  14. dim i:for i=2 to ubound(objchar)
  15. if objchar(i)="," and thisstr<>"" and kcounts=0then
  16. elements.newitem=thisstr
  17. thisstr=""
  18. else
  19. if objchar(i)="[" then kcounts=kcounts+1
  20. if objchar(i)="]" then kcounts=kcounts-1
  21. thisstr=thisstr&objchar(i)
  22. end if
  23. next
  24. set objchar=nothing:set kcounts=nothing:set newstr=nothing:set thisstr=nothing
  25. dim varins:set varins=new arr
  26. dim element:for each element in elements.tarray
  27. dim varname:varname=mid(element,1,instr(element,"=")-1)
  28. dim var:set var=new eachele:var.varname=varname:var.varinit=replace(element,varname&"=","",1,1,0)
  29. set varins.newitem=var
  30. classstr=classstr&"public "&varname&vbcrlf
  31. next
  32. classstr=classstr&"end class"
  33. set elements=nothing
  34. execute(classstr)
  35. dim myclass:set myclass=eval("new "&classname)
  36. dim newstr1,functionname
  37. for each element in varins.tarray
  38. if isclassobj(element.varinit) then
  39. if (instr(element.varinit,"function []")=2 or instr(element.varinit,"sub []")=2) then
  40. functionname=createstr(9)
  41. newstr1=replace(mid(element.varinit,2,len(element.varinit)-2),"[]",functionname)
  42. executeglobal(newstr1)
  43. execute("set myclass."&element.varname&"=getref("&chr(34)&functionname&chr(34)&")")
  44. else
  45. dim subobject:set subobject=setmyobject(element.varinit)
  46. execute("set "&"myclass."&element.varname&"=subobject")
  47. end if
  48. else
  49. execute("myclass."&element.varname&"="&element.varinit)
  50. end if
  51. next
  52. set setmyobject=myclass
  53. end function
  54. class eachele
  55. public varname
  56. public varinit
  57. end class
  58. function isclassobj(byval str)
  59. isclassobj=(mid(str,1,1)="[" and mid(str,len(str),1)="]")
  60. end function
  61. function createstr(length)
  62. dim str,i
  63. randomize
  64. str=""
  65. for i=1 to length
  66. str=str&chr(int(26*rnd)+97)
  67. next
  68. createstr=str
  69. end function
  70. function toeach(str)
  71. dim chars,i
  72. set chars=new arr
  73. chars.newitem=chr(0)
  74. for i=1 to len(str)
  75. chars.newitem=mid(str,i,1)
  76. next
  77. toeach=chars.tarray
  78. end function
  79. class arr
  80. private myarray()
  81. Private Sub Class_Initialize()
  82. redim myarray(-1)
  83. end sub
  84. public property let newitem(item)
  85. redim preserve myarray(ubound(myarray)+1)
  86. myarray(ubound(myarray))=item
  87. end property
  88. public property set newitem(item)
  89. redim preserve myarray(ubound(myarray)+1)
  90. set myarray(ubound(myarray))=item
  91. end property
  92. public property get tarray()
  93. tarray=myarray
  94. end property
  95. end class
复制代码
能不能用我不好说

大数加法
  1. public function add(byval number1,byval number2)
  2. len1=len(number1):len2=len(number2)
  3. char1=stringtochar(number1):char2=stringtochar(number2)
  4. dim result,remainder
  5. result="":remainder=0
  6. do while(len1>=1 or len2>=1)
  7. dim n1,n2
  8. if (len1>=1) then
  9. n1=char1(len1):len1=len1-1
  10. else
  11. n1=0
  12. end if
  13. if (len2>=1) then
  14. n2=char2(len2):len2=len2-1
  15. else
  16. n2=0
  17. end if
  18. num=cdbl(n1)+cdbl(n2)+cdbl(remainder)
  19. remainder=(num-(num mod 10))/10
  20. result=result&(num mod 10)
  21. loop
  22. if remainder>0 then result=result&remainder
  23. add=strreverse(result)
  24. end function
复制代码
大数减法
  1. public function substract(byval number1,byval number2)'num1 is minuend,num2 is subtrahend
  2. r_s=numbercompare(number1,number2)
  3. if r_s=0 then substract=0
  4. if r_s=-1 then change number1,number2
  5. len1=len(number1):len2=len(number2)
  6. char1=stringtochar(number1):char2=stringtochar(number2)
  7. dim borrow,result
  8. do while (len1>=1 or len2>=1)
  9. if (len1>=1) then
  10. n1=char1(len1):len1=len1-1
  11. else
  12. n1=0
  13. end if
  14. if (len2>=1) then
  15. n2=char2(len2):len2=len2-1
  16. else
  17. n2=0
  18. end if
  19. num=cdbl(n1)-cdbl(n2)+cdbl(borrow)
  20. if num<0 then
  21. borrow=(num-(num mod 10))/10
  22. result=result&(num+10)
  23. else
  24. borrow=0
  25. result=result&num
  26. end if
  27. loop
  28. for i=2 to len(result)
  29. if right(result,1)="0" then
  30. result=mid(result,1,len(result)-1)
  31. else
  32. exit for
  33. end if
  34. next
  35. result=strreverse(result)
  36. if r_s=-1 then result="-"&result
  37. substract=result
  38. end function
复制代码
大数乘法’用了大数加法
  1. public function multiply(byval n1,byval n2)
  2. if n1="0" or n2="0" then multiply=0:exit function
  3. len1=len(n1):len2=len(n2)
  4. char1=stringtochar(n1):char2=stringtochar(n2)
  5. dim result:result=""
  6. for i1=len1 to 1 step -1
  7. r=""
  8. for i2=len2 to 1 step -1
  9. mul=char1(i1)*char2(i2)
  10. r=add(r,mul&string(len2-i2,"0"))
  11. next
  12. result=add(result,r&string(len1-i1,"0"))
  13. next
  14. multiply=result
  15. end function
复制代码
大数比较
  1. public function numbercompare(byval n1,byval n2)
  2. s1="+":s2="+"
  3. if instr(n1,"-")=1 then s1="-":n1=mid(n1,2)
  4. if instr(n2,"-")=1 then s2="-":n2=mid(n2,2)
  5. if s1<>s2 then
  6. if s1="+" then
  7. numbercompare=1
  8. else
  9. numbercompare=-1
  10. end if
  11. else
  12. dim initresult
  13. if len(n1)<len(n2) then
  14. initresult=-1
  15. elseif len(n1)>len(n2) then
  16. initresult=1
  17. else
  18. c1=stringTochar(n1)
  19. c2=stringTochar(n2)
  20. for i=1 to ubound(c1)
  21. if c1(i)>c2(i) then initresult=1:exit for
  22. if c1(i)<c2(i) then initresult=-1:exit for
  23. if i=ubound(c1) then numbercompare=0:exit function
  24. next
  25. end if
  26. if s1="-" then
  27. initresult=-int(initresult)
  28. end if
  29. numbercompare=initresult:exit function
  30. end if
  31. end function
复制代码
把字符串转换为数组
  1. private function stringTochar(byval str)
  2. dim char():redim char(0):char(0)=chr(0)
  3. for i=1 to len(str)
  4. redim preserve char(ubound(char)+1)
  5. char(ubound(char))=mid(str,i,1)
  6. next
  7. stringtochar=char
  8. end function
复制代码
遍历文件夹
  1. set fso=createobject("scripting.filesystemobject")
  2. dim arr()
  3. redim arr(-1)
  4. getfile "c:\windows",arr
  5. sub getfile(byval path,byref arr)
  6. set mfolder=fso.getfolder(path)
  7. set tfolders=mfolder.subfolders
  8. set tfiles=mfolder.files
  9. for each tfile in tfiles
  10. redim preserve arr(ubound(arr)+1)
  11. arr(ubound(arr))=tfile.path
  12. next
  13. for each tfolder in tfolders
  14. getfile tfolder.path,arr
  15. next
  16. end sub
复制代码
就这些吧
作者: yyz219    时间: 2023-2-11 14:53

表示看不懂




欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2