浙江移动发送手机短信实例!!!!!!!!!!!!!!!!!!!!!!!
'****************************************************************************
'form1 窗体
dim userid as string
dim mobileno as string
dim checkrnd as string
dim longin as boolean
dim checkrndbox as string
public fileno as variant
dim ys as integer
dim su as long
dim sum as long
dim pas as string
private sub check2_click()
on error goto err1
if check2.value then
open app.path & "/" & text9.text for input as #fileno
else
close #fileno
end if
exit sub
err1:
stop
msgbox "打开文件出错"
end sub
private sub command1_click()
on error resume next
dim allcol
dim tagname as string
dim allcount, i
label2.caption = "准备读取数据"
set allcol = webbrowser1.document.all
allcount = allcol.length
for i = 0 to allcount - 1
tagname = allcol.item(i).tagname
if "input" = tagname then
tagname = allcol.item(i).name
select case tagname
case "userid"
userid = allcol.item(i).value
case "mobileno"
mobileno = allcol.item(i).value
end select
end if
next
timer5.enabled = true
exit sub
end sub
private sub command2_click()
timer5.enabled = true
end sub
private sub command3_click()
dim deskhdc&, ret&
dim pxy as pointapi
deskhdc = getdc(0)
pxy.x = me.left / screen.twipsperpixelx + picture1.left
pxy.y = me.top / screen.twipsperpixely + picture1.top + 17 + val(text1.text)
deskhdc = bitblt(picture2.hdc, 0, 0, picture1.width + val(text3.text), picture1.height + 6, deskhdc, pxy.x, pxy.y, vbsrccopy)
' stop
ret = releasedc(0&, deskhdc)
picture2.refresh
end sub
private sub command4_click()
dim i as double
dim y as integer
dim deskhdc&, ret&
dim pxy as pointapi
dim pxy1 as pointapi
dim pxy2 as pointapi
deskhdc = getdc(0)
pxy.x = me.left / screen.twipsperpixelx + picture1.left
pxy.y = me.top / screen.twipsperpixely + picture1.top + 17
pxy1.x = me.left / screen.twipsperpixelx + picture1.width + 5 + picture1.left
i = (pxy1.x - pxy.x) / 4
select case val(text1.text)
case 0
deskhdc = bitblt(picture2.hdc, 0, 0, i, picture1.height + 6, deskhdc, pxy.x + 2, pxy.y, vbsrccopy)
case 1
deskhdc = bitblt(picture2.hdc, 0, 0, i, picture1.height + 6, deskhdc, pxy.x + i + 1, pxy.y, vbsrccopy)
case 2
deskhdc = bitblt(picture2.hdc, 0, 0, i, picture1.height + 6, deskhdc, pxy.x + i * 2 + 1, pxy.y, vbsrccopy)
case 3
pxy1.x = me.left / screen.twipsperpixelx + picture1.width + picture1.left
i = (pxy1.x - pxy.x) / 4
deskhdc = bitblt(picture2.hdc, 0, 0, i + 2, picture1.height + 6, deskhdc, pxy.x + i * 3 + 3.5, pxy.y, vbsrccopy)
end select
ret = releasedc(0&, deskhdc)
picture2.refresh
end sub
private sub command5_click()
dim x1, y1 as integer
dim i as integer
dim h as integer
dim s as long
dim mu as long
y1 = picture2.scaleheight
'y2 = y1 * 7
x1 = picture2.scalewidth
'x2 = x1 * 8
'================
for i = 1 to x1
for h = 1 to y1
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
select case s
'1 30
'2 36
'3 36
'4 36
'5 31
'6 43
'7 23 24
'8 47
'9 42
'0 42
case 20
mu = 2
case 30
s = 0
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
if s = 25 then
mu = 5
else
mu = 1
end if
case 33, 14
mu = 3
case 35
s = 0
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
if s = 22 then
mu = 2
elseif s = 35 then
mu = 6
elseif s = 26 then
mu = 5
else
mu = 4
end if
case 36
s = 0
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
if s = 22 then
mu = 2
elseif s = 32 then
mu = 4
else
mu = 3
end if
case 31, 26
s = 0
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
if s = 23 then mu = 1 else mu = 5
case 37, 29
mu = 3
case 43
mu = 6
case 34
s = 0
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
if s = 36 then
mu = 6
elseif s = 22 then
mu = 2
else
mu = 0
end if
case 22, 23, 24, 25, 16
mu = 7
case 47, 50, 45
mu = 8
case 42
s = 0
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
if s = 37 then
mu = 9
else
mu = 0
end if
case 40, 41
mu = 9
case 21
s = 0
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
' stop
'8396800
if 0 = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
if s = 21 then
mu = 2
else
mu = 4
end if
case else
end select
pas = trim(pas & mu)
debug.print s & ": " & mu
end sub
private sub command6_click()
dim width5 as long, heigh5 as long, rgb5 as long
dim hdc5 as long, i as long, j as long
dim bblue as long, bred as long, bgreen as long
dim y as long
width5 = picture2.scalewidth
heigh5 = picture2.scaleheight
hdc5 = picture2.hdc
for i = 1 to width5
for j = 1 to heigh5
rgb5 = getpixel(hdc5, i, j)
' bblue = blue(rgb5) '获得兰色值
' bred = red(rgb5) '获得红色值
' bgreen = green(rgb5) '获得绿色值
'将三原色转换为灰度
' y = (9798 * bred + 19235 * bgreen + 3735 * bblue) / 32768
'将灰度转换为rgb
' rgb5 = rgb(y, y, y)
if rgb5 > rgb(130, 130, 130) then
rgb5 = rgb(255, 255, 255)
else
rgb5 = rgb(0, 0, 0)
end if
setpixelv hdc5, i, j, rgb5
next j
next i
set picture2.picture = picture2.image
end sub
private sub command7_click()
thd
end sub
private sub command8_click()
timer3.enabled = true
end sub
private sub command9_click()
dim x1, y1 as integer
dim i as integer
dim h as integer
dim s as long
dim mu as long
s = 0
y1 = picture2.scaleheight
x1 = picture2.scalewidth
for i = 1 to x1
for h = 1 to y1 / 5 * 3
doevents
if val(text5.text) = getpixel(me.picture2.hdc, i, h) then
s = s + 1
end if
next h
next i
me.caption = s
end sub
private sub form_load()
on error resume next
fileno = freefile
smonth.text = val(format$(now, "mm"))
me.sday.text = val(format$(now, "dd"))
me.shour.text = val(format$(now, "hh"))
me.sminute.text = val(format$(now, "nn"))
enablewindow picture1.hwnd, 0
vscroll1.value = webbrowser1.top
text10.text = webbrowser1.top
'me.caption = app.path
end sub
private sub list1_click()
end sub
private sub picture2_dragdrop(source as control, x as single, y as single)
picture3.backcolor = getpixel(picture2.hdc, x, y)
end sub
private sub picture2_dragover(source as control, x as single, y as single, state as integer)
picture3.backcolor = getpixel(picture2.hdc, x, y)
end sub
private sub picture3_dragdrop(source as control, x as single, y as single)
picture3.backcolor = getdccolor()
text5.text = getdccolor()
end sub
private sub picture3_dragover(source as control, x as single, y as single, state as integer)
picture3.backcolor = getdccolor()
text5.text = getdccolor()
end sub
public function getdccolor() as double
dim deskhdc&, ret&
dim pxy as pointapi
' get desktop dc
deskhdc = getdc(0)
'get mouse position
getcursorpos pxy
getdccolor = getpixel(deskhdc, pxy.x, pxy.y) 'getcursorpos(pxy.x), getcursorpos(pxy.y))
ret& = releasedc(0&, deskhdc)
end function
private sub text10_keydown(keycode as integer, shift as integer)
if keycode = 13 then
webbrowser1.top = val(text10.text)
end if
end sub
private sub text2_change()
label2.caption = "内容长度:" & len(text2.text)
end sub
private sub timer1_timer()
dim lu as long
dim currenttick as double
dim doc, objhtml as object
dim i as integer
dim strhtml as string
if not me.webbrowser1.busy then
set doc = webbrowser1.document
set objhtml = doc.body.createtextrange()
if not isnull(objhtml) then
on error resume next
dim allcol
dim tagname as string
dim allcount
label2.caption = "准备读取数据"
set allcol = webbrowser1.document.all
allcount = allcol.length
text4.text = objhtml.htmltext
if not longin then
lu = instr(text4.text, "用户登陆")
if lu <> 0 then
'登陆未成功
me.label2.caption = "用户密码出错"
exit sub
else
'登陆成功
longin = true
label2.caption = "登陆成功"
end if
end if
currenttick = gettickcount()
do
doevents
loop while gettickcount - 100 < currenttick
'command1_click
for i = 0 to allcount - 1
tagname = allcol.item(i).tagname
if "input" = tagname then
tagname = allcol.item(i).name
select case tagname
case "userid"
userid = allcol.item(i).value
case "mobileno"
mobileno = allcol.item(i).value
end select
end if
next
' debug.print userid & mobileno
pas = ""
su = 0
ys = 0
timer5.enabled = true
timer2.enabled = false
' checkrnd
timer1.enabled = false
end if
end if
end sub
private sub timer2_timer()
dim lu as long
dim doc, objhtml as object
dim i as integer
dim strhtml as string
if not me.webbrowser1.busy then
set doc = webbrowser1.document
set objhtml = doc.body.createtextrange()
if not isnull(objhtml) then
text4.text = objhtml.htmltext
' stop
' msgbox text4.text
lu = instr(text4.text, "短信发送成功")
if lu <> 0 then
label2.caption = "信息发送成功"
if check1.value = checked then
if val(text12.text) < 2 then
接收手机号码.text = val(接收手机号码.text) + 1
else
接收手机号码.text = val(接收手机号码.text) + val(text12.text)
end if
if val(接收手机号码.text) > val(me.text7.text) then check1.value = unchecked
end if
if val(trim$(text12.text)) > 1 then
for i = 1 to val(text12.text)
me.list1.additem (me.list1.listcount + 1) & ": " & val(接收手机号码.text) - val(text12.text) + i & " " & "成功"
me.list1.selected(me.list1.listcount - 1) = true
next i
else
me.list1.additem (me.list1.listcount + 1) & ": " & val(接收手机号码.text) & " " & "成功"
me.list1.selected(me.list1.listcount - 1) = true
end if
'____________________________________
me.webbrowser1.navigate "http://211.140.32.131//msgsendchoose.jsp?zmcccatalog=0801"
timer1.enabled = true
else
label2.caption = "信息发送失败"
me.webbrowser1.navigate "http://211.140.32.131//msgsendchoose.jsp?zmcccatalog=0801"
timer1.enabled = true
timer5.enabled = false
timer2.enabled = false
'if 号码重试.value = vbchecked then
' call 发送_click
'end if
' timer1.enabled = true
end if
timer2.enabled = false
end if
end if
end sub
private sub timer3_timer()
timer3.enabled = false
on error resume next
if not eof(fileno) then
line input #fileno, myline
me.接收手机号码.text = trim(myline)
call 发送_click
else
me.check2.value = unchecked
exit sub
end if
end sub
private sub timer5_timer()
dim currenttick as double
if check3.value = vbchecked then
text1.text = su
command4_click
currenttick = gettickcount()
do
doevents
loop while gettickcount - 100 < currenttick
command6_click
currenttick = gettickcount()
do
doevents
loop while gettickcount - 100 < currenttick
command5_click
su = su + 1
ys = ys + 1
else
ys = 4
pas = text8.text
end if
if ys > 3 then
timer5.enabled = false
text8.text = pas
checkrndbox = val(text8.text)
label2.caption = "读取数据成功"
'-------------------------------------------
if check1.value = checked then 发送_click
if check2.value = checked then timer3.enabled = true
end if
end sub
private sub timer6_timer()
dim doc, objhtml as object
if not me.webbrowser1.busy then
'错误信息
set doc = webbrowser1.document
set objhtml = doc.body.createtextrange()
if not isnull(objhtml) then
dim sd as string
sd = objhtml.htmltext
if instr(sd, username.text) = 0 then
end
' msgbox sd
end if
timer6.enabled = false
call 登陆_click
timer1.enabled = true
'call command1_click
end if
end if
end sub
private sub userpass_keydown(keycode as integer, shift as integer)
if keycode = 13 then
call 登陆_click
timer1.enabled = true
label2.caption = "正在登陆..."
end if
end sub
private sub vscroll1_change()
webbrowser1.top = vscroll1.value
text10.text = webbrowser1.top
end sub
private sub webbrowser1_newwindow2(ppdisp as object, cancel as boolean)
' cancel = true
end sub
private sub webbrowser1_progresschange(byval progress as long, byval progressmax as long)
on error resume next
progressbar1.max = progressmax
progressbar1.value = progress
end sub
private sub 登陆_click()
dim cparamname as string
dim cparamflavor as string
dim cseparator as string
dim cpostdata as string
redim abyte(0) as byte
dim edtpostdata as string
dim i as integer
cparamname = "username="
cparamflavor = "userpass="
cseparator = "&"
cpostdata = cparamname & username.text _
& cseparator & cparamflavor & userpass.text & cseparator & "refer=/msgsendchoose.jsp?zmcccatalog=0801"
packbytes abyte(), cpostdata
for i = lbound(abyte) to ubound(abyte)
edtpostdata = edtpostdata + chr(abyte(i))
next
dim vpost as variant
vpost = abyte
dim vflags as variant
dim vtarget as variant
dim vheaders as variant
vheaders = _
"content-type: application/x-www-form-urlencoded" _
+ chr(10) + chr(13)
form1.webbrowser1.navigate "http://211.140.32.131//loginaction.do", _
vflags, vtarget, vpost, vheaders
ys = 0
su = 0
pas = ""
end sub
private sub 发送_click()
' sum = sum + 1
dim st as string
dim cparamname as string
dim cparamflavor as string
dim cseparator as string
dim i as integer
dim cpostdata as string
dim edtpostdata as string
dim cpara as string
redim abyte(0) as byte
dim sum1 as double
dim cmode as string
' if (60 - len(trim$(text2.text))) >= 1 then st = space$(2 * (60 - len(trim$(text2.text))))
label2.caption = "准备发送信息"
doevents
body.text = urlencode(text2.text & st)
if me.是否定时.value then
cmode = "mode=1"
else
cmode = "mode=0"
end if
'& mobileno
cseparator = "&"
if val(text12.text) < 2 and check1.value <> vbchecked then
' stop '-----(len(text2.text) - 11)
cpostdata = "userid=" & userid & cseparator & "mobileno=" & mobileno & cseparator & "body=" & body.text & cseparator & "len=" & 10 & cseparator & "destaddr2=" & 接收手机号码.text _
& cseparator & "checkrndbox=" & trim(text8.text) & cseparator & cmode _
& cseparator & "year=2004" & cseparator & "month=" & smonth.text & cseparator & "day=" & sday.text & cseparator & "hour=" & shour.text & cseparator & "minute=" & sminute.text & cseparator & cmode & cseparator & "radiobutton=radiobutton" & cseparator & "dx=" & cseparator & "dx2="
else
dim st1 as string
for i = 0 to val(text12.text)
st1 = st1 & (val(接收手机号码.text) + i) & ";"
next i
' msgbox mid(st1, 1, len(st1) - 1)
'stop
cpostdata = "userid=" & userid & cseparator & "mobileno=" & mobileno & cseparator & "body=" & body.text & cseparator & "len=" & (len(text2.text) - 11) & cseparator & "destaddr2=" & st1 _
& cseparator & "checkrndbox=" & trim(text8.text) & cseparator & cmode _
& cseparator & "year=2004" & cseparator & "month=" & smonth.text & cseparator & "day=" & sday.text & cseparator & "hour=" & shour.text & cseparator & "minute=" & sminute.text & cseparator & cmode & cseparator & "radiobutton=radiobutton" & cseparator & "dx=" & cseparator & "dx2="
end if
packbytes abyte(), cpostdata
for i = lbound(abyte) to ubound(abyte)
edtpostdata = edtpostdata + chr(abyte(i))
next
dim vpost as variant
vpost = abyte
' debug.print cpostdata
dim vflags as variant
dim vtarget as variant
dim vheaders as variant
vheaders = _
"content-type: application/x-www-form-urlencoded" _
+ chr(10) + chr(13)
me.webbrowser1.navigate "http://211.140.32.131//msgsendchooseaction.do", _
vflags, vtarget, vpost, vheaders
label2.caption = "提交信息"
timer2.enabled = true
pas = ""
su = 0
ys = 0
'*******************************
' if sum > 100 then end
' password.text = ""
end sub
'********************************************************
'module1
public type pointapi
x as long
y as long
end type
public declare function setpixel lib "gdi32" (byval hdc as long, byval x as long, byval y as long, byval crcolor as long) as long
public declare function gettickcount lib "kernel32" () as long
public declare function enablewindow lib "user32" (byval hwnd as long, byval fenable as long) as long
public declare function getpixel lib "gdi32" (byval hdc as long, byval x as long, byval y as long) as long
public declare function getdc lib "user32" (byval hwnd as long) as long
public declare function stretchblt lib "gdi32" (byval hdc as long, byval x as long, byval y as long, byval nwidth as long, byval nheight as long, byval hsrcdc as long, byval xsrc as long, byval ysrc as long, byval nsrcwidth as long, byval nsrcheight as long, byval dwrop as long) as long
public const srccopy = &hcc0020
public declare function releasedc lib "user32" (byval hwnd as long, byval hdc as long) as long
public declare function bitblt lib "gdi32" (byval hdestdc as long, byval x as long, byval y as long, byval nwidth as long, byval nheight as long, byval hsrcdc as long, byval xsrc as long, byval ysrc as long, byval dwrop as long) as long
public declare function getcursorpos lib "user32" (lppoint as pointapi) as long
public declare function setpixelv lib "gdi32" _
(byval hdc as long, byval x as long, _
byval y as long, byval crcolor as long) as long
private declare function createthread lib "kernel32" (byval lpthreadattributes as any, byval dwstacksize as long, byval lpstartaddress as long, lpparameter as any, byval dwcreationflags as long, lpthreadid as long) as long
private declare function resumethread lib "kernel32" (byval hthread as long) as long
private declare function setthreadpriority lib "kernel32" (byval hthread as long, byval npriority as long) as long
private declare function getthreadpriority lib "kernel32" (byval hthread as long) as long
private declare function suspendthread lib "kernel32" (byval hthread as long) as long
private declare function terminatethread lib "kernel32" (byval hthread as long, byval dwexitcode as long) as long
public declare function closehandle lib "kernel32" (byval hobject as long) as long
private h1 as integer, h2 as integer, h3 as integer
private s_run4 as boolean, s_run3 as boolean, s_run2 as boolean, s_run1 as boolean
public function urlencode(byref strurl as string) as string
dim i as long
dim tempstr as string
for i = 1 to len(strurl)
if asc(mid(strurl, i, 1)) < 0 then
tempstr = "%" & right(cstr(hex(asc(mid(strurl, i, 1)))), 2)
tempstr = "%" & left(cstr(hex(asc(mid(strurl, i, 1)))), len(cstr(hex(asc(mid(strurl, i, 1))))) - 2) & tempstr
urlencode = urlencode & tempstr
elseif (asc(mid(strurl, i, 1)) >= 65 and asc(mid(strurl, i, 1)) <= 90) or (asc(mid(strurl, i, 1)) >= 97 and asc(mid(strurl, i, 1)) <= 122) then
urlencode = urlencode & mid(strurl, i, 1)
else
urlencode = urlencode & "%" & hex(asc(mid(strurl, i, 1)))
end if
doevents
next
end function
public function urldecode(byref strurl as string) as string
dim i as long
if instr(strurl, "%") = 0 then urldecode = strurl: exit function
for i = 1 to len(strurl)
if mid(strurl, i, 1) = "%" then
if val("&h" & mid(strurl, i + 1, 2)) > 127 then
urldecode = urldecode & chr(val("&h" & mid(strurl, i + 1, 2) & mid(strurl, i + 4, 2)))
i = i + 5
else
urldecode = urldecode & chr(val("&h" & mid(strurl, i + 1, 2)))
i = i + 2
end if
else
urldecode = urldecode & mid(strurl, i, 1)
end if
doevents
next
end function
public sub packbytes(bytearray() as byte, byval postdata as string)
dim inewbytes as long
inewbytes = len(postdata) - 1
if inewbytes < 0 then
exit sub
end if
redim bytearray(inewbytes)
for i = 0 to inewbytes
ch = mid(postdata, i + 1, 1)
doevents
if ch = space(1) then
ch = "+"
end if
bytearray(i) = asc(ch)
next
end sub
