分类目录归档:VB程序

VB设置WebBrowser1的IE版本

VB内嵌网页,好像只有 WebBrowser 控件 嵌入。开发过程中遇到一个非常变态的问题,无论目标主机 安装的什么IE版本,都是按IE7的模式显示。现在很多网站已经不支持IE7了,这个问题非常蛋疼。

翻阅了很多资料,最终在 Stack Overflow(http://stackoverflow.com/questions/14974502/c-sharp-internet-explorer-9-and-axwebbrowser)找到了解决方法。不仅能解决VB的WebBrowser1的IE版本控制。还能解决C#的IE版本控制,VB.Net的IE版本控制。操作非常简单 继续阅读

VB+HTML实现Win8界面

天天和WEB打交道,忽然需要写个客户端,就傻眼了把。没有CSS,没有JQuery,还写个毛。调用默认额度控件,又丑死了,而且非常不灵活。如果把HTML和VB结合起来,做客户端界面就爽多了。

实在郁闷,在网上偶尔找到了HyperApp.cls,好东西啊,在他的基础上我扩展了些,写出来了一个演示程序。

继续阅读

ASP文本存储方案-FileDB

四月份做个一个短信系统,当时为了节省成本(使用万网的空间,不带SQL数据库空间便宜),使用了ASP+Access开发,最近需要升级,增加一个短信接口。发现现在Access的数据库竟然有170MB。我的天啊,因为查询比较少,不是很耗资源,所以没有检查出来。
仅仅六个月,数据库竟然到了170MB。随着客户业务的增长,可能再过六个月就要到500MB了,真恐怖。主要占空间大小的,就是存储的短信的发送号码,思考再三,决定将所有的保存到文本文件中。于是写下了一个暂时成为FileDB的asp类。

Class FileDB
  Dim fso,IdxKey,DBPath
  Private Sub Class_Initialize
    Set fso = Server.CreateObject("Scripting.FileSystemObject")
    idxKey = "demo::test"
    DBPath = "DataCenter/File_DB/"
  End Sub

  Private Function getPath()
    Dim tmp
    getPath = replace(idxKey,"::","/") & ".html"
  End Function

  Private Function checkFile(byref fname)
    fname = Server.Mappath(DBPath & getPath())
    checkFile = fso.fileexists(fname)
  End Function

  Private Sub createPathName(byval idxKey)
    Dim TmpPa
    TmpPa = Server.Mappath(DBPath & idxKey)
    if not fso.folderexists(TmpPa) then
      if instr(idxKey,"\") > 0 then Call createPathName(left(idxKey,instrrev(idxKey,"\")-1))
      fso.createfolder(TmpPa)
    end if
  End Sub

  Public Function getTxt()
    if checkFile(fname) then
      set Txt = fso.getfile(fname)
      if Txt.size = 0 then
        Tmp = ""
      else
        Tmp = fso.opentextfile(fname).readall
      end if
      set Txt = Nothing
      getTxt = Tmp
    else
      getTxt = ""
    end if
  End Function

  Public Function remove()
    if checkFile(fname) then
      fso.deletefile fname
    end if
  End Function

  Public Function Save(byval content)
    if checkFile(fname) then
      set fpo = fso.opentextfile(fname,2)
    else
      idxKey = replace(idxKey,"::","\")
      if instr(idxKey,"\")>0 then Call createPathName(left(idxKey,instrrev(idxKey,"\")-1))
      set fpo = fso.createtextfile(fname)
    end if
    fpo.write content
    fpo.close
    set fpo = nothing
  End Function
End Class

因为时间比较紧,而且代码比较简单,就不加注释了,实际就是简化了文本文件的操作方法。

<% Server.ScriptTimeOut=10000 %> 
<%
  '数据库链接代码
  
  set fdb = new FileDB
  fdb.DBPath = "../DataCenter/sms_DB/"
    
  conn.open constr
  set rs = server.createobject("ADODB.Recordset")
  '得到所有没有转换的数据
  rs.open "select * from sendlog where send_mob not like '%::%'",conn,3,2
  do while not rs.eof
    'FileDB 数据存放路径,日期::MD5(ID)
    idxStr = split(Rs("send_date")," ")(0) & "::" & md5(Rs("send_id"))
    fdb.IdxKey = idxStr
    fdb.Save(Rs("send_mob"))
    Rs("send_mob") = idxStr
    rs.update
    rs.movenext
  loop
  rs.close
  conn.close
  
  '数据库压缩过程,不是重点,再次不再多述
  compactdata(DataPath)
%>
减肥成功,所有数据转存到FileDB中。

执行一下,所有数据就转存好了,读取的时候很简单,指定了 idxStr,用getTxt()即可得到内容。

  set fdb = new FileDB
  fdb.DBPath = "../DataCenter/sms_DB/"
  '../DataCenter/sms_DB/aaa/1111.txt
  fdb.idxKey = "aaa::1111"
  str1 = fdb.getTxt()
  '../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt
  fdb.idxKey = "bbb:ccc::ddd:eee"
  str2 = fdb.getTxt()
  '删除 ../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt
  fdb.remove() 
  '因为文件不存在,得到的值就是空字符串
  str3 = fdb.getTxt()
  '将内容保存到../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt,因为不存在则创建,如果存在,则修改。
  fdb.save("11111")

2010年10月24日更新小Bug,修复了idxKey 定于数据存放在根目录,就会报错的错误

pushWeb 小更新

以前写过一篇PushWeb 采集站点信息发布的最佳方案(http://www.miaoqiyuan.cn/p/pushweb),用了很久,现在数据量大了,导入速度很慢(主要原因是导入一条记录,自动修复一次数据),在此,我修改了一下代码,暂且算是升级到1.01吧:

'pushWeb 1.01

'刷新时间
const pushWeb_flush_Time=600000
'数据库路径
const pushWeb_dbPath="D:\WebDesign\Products\pushWeb\DB\PushWebDB.mdb"


function pushWeb()
	on error resume next
	dim conn,rs,push_id,push_webid,push_sql
	dim web_db,web_name
	dim push_Arr,push_str
	
	set conn=createobject("ADODB.connection")
	conn.open "provider=microsoft.jet.oledb.4.0;data source="&pushWeb_dbPath
	set rs=conn.execute("select push_webid from push")
	if rs.eof then
		push_id=0
		wscript.echo "没有更新,"&pushWeb_flush_Time/1000&"秒后再检查..."
	else
		push_webid=rs(0)
	end if
	rs.close
	set rs=nothing
	
	if push_webid<>0 then
		'载入站点信息
		set rs=conn.execute("select web_name,web_db from web where web_id="&push_webid)
		if not rs.eof then
			web_name=rs(0)
			web_db=rs(1)
		else
			wscript.echo "错误的任务请求,"&pushWeb_flush_Time/1000&"秒后再检查..."
			exit function
		end if
		rs.close
		set rs=nothing
		
		'如果是合法的站点
		if web_db<>"" and web_name<>"" then
			wscript.echo "找到一个任务[站点名="&web_name&"],导入中..."
			'创建新的连接对象
			set newConn=CreateObject("ADODB.Connection")
			newConn.open web_db
			
			set rs=conn.execute("select push_sql from push where push_webid="&push_webid)
			
			do while not rs.eof
				push_sql=rs(0)
				push_Arr=split(push_sql,vbCrlf)
				for each push_str in push_Arr
					wscript.echo "插入一条数据..."
					if trim(push_str)<>"" then newConn.execute(trim(push_str))
				next
				rs.movenext
			loop

			'清空该站点下的所有任务
			conn.execute("delete from push where push_webid="&push_webid)

			wscript.sleep 100
			wscript.echo "开始修复数据..."
			'修复数据
			set repairRs=createobject("ADODB.recordset")
			repairRs.open "select * from NC_softList",newConn,3,2
			do while not repairRs.eof
				if not isnull(repairRs("Content")) then repairRs("Content")=replace(replace(repairRs("Content"),"{’}","'"),"{\n}",vbCrlf)
				repairRs.update
				repairRs.movenext
			loop
			repairRs.close
			set repairRs=nothing
			wscript.sleep 100
		end if
	else
		wscript.sleep pushWeb_flush_Time
	end if
	wscript.echo string(60,"=")
	call pushWeb()
end function


wscript.echo string(60,"=")
wscript.echo "pushWeb version:1.01"
wscript.echo "pushWeb Design:苗启源"
wscript.echo "pushWeb Home:miaoqiyuan.cn"
wscript.echo string(60,"=")
wscript.echo "pushWeb Starting..."
wscript.echo string(60,"=")
call pushWeb()

CMDPad 批处理辅助工具

CMDPad 批处理辅助工具

cmdpad-1

通过YQYStudio助手功能,即使不懂批处理命令,仅需点几下鼠标,也可以写出功能强大的批处理工具。
cmdpad-2

复杂的逻辑命令,点击即可获得简单的使用说明。
cmdpad-3

可以通过菜单或者快捷键(Ctrl+E)关闭源奇缘助手,通过(Ctrl+Y)开启源奇缘助手
cmdpad-41

可以通过菜单修改背景颜色,字体颜色,字体大小,文字字体。
cmdpad-5

通过批处理辅助(Alt+C)即可打开批处理辅助菜单,可以通过简单的选择菜单,即可生成相应的批处理命令。
cmdpad-6

下载CMDPad 批处理辅助工具

CMDPad 批处理辅助工具文档

CMDPad 批处理辅助工具源码

TENCENT协议的实现原理-通过自定义协议执行程序

通过Tencent://Message/可以打开QQ和朋友聊天,一直对他挺好奇?到底是什么原理?
今天,我在网上找了一下TENCENT协议的实现原理,还真找到了;文章请访问:http://hi.baidu.com/kmiaoer/blog/item/799fd388ec403691a5c2723b.html
原来是在注册表中修改的。
知道了原理就好办了,我们也来写一个

定义一个miaoqiyuan协议。实现什么功能的,哦,多了,miaoqiyuan:你好。这样来实现弹出对话框,弹出你好。

Windows Registry Editor Version 5.00
 
[HKEY_CLASSES_ROOT\miaoqiyuan]
@="miaoqiyuan Protocol"
"URL Protocol"="D:\\miaoqiyuan\\miaoqiyuan.exe"
 
[HKEY_CLASSES_ROOT\Smiaoqiyuan\DefaultIcon]
@="D:\\miaoqiyuan\\miaoqiyuan.exe,0"
 
[HKEY_CLASSES_ROOT\miaoqiyuan\shell]
 
[HKEY_CLASSES_ROOT\miaoqiyuan\shell\open]
 
[HKEY_CLASSES_ROOT\miaoqiyuan\shell\open\command]
@=\"D:\\miaoqiyuan\\miaoqiyuan.exe\" %1"

这样,通过miaoqiyuan:链接的文件都可以通过miaoqiyuan.exe打开了

下面说说怎样来弹出对话框。

在VB中新建一个标准的EXE程序,新建一个按钮,改名为Showmsg,双击,输入END(点击退出程序)

然后添加

Private Sub Form_Load()
    showmsg.Caption = Replace(Command(), "miaoqiyuan:", "")
End Sub

这样就可以通过输入miaoqiyuan:1234弹出1234的警告了

这样就可用通过一个自定义的协议来执行程序了