VB程序员博客
06 3rd, 2009
现在主要问题是：发的帖子都是只有标题的帖子，正文部分没有信息；
把信息填充到正文文本框的部分一直没弄成功。。。
请大家帮忙看下，谢谢。。。
发帖页面部分源代码——————————————-
<em>标题 </em> <input type="text" size="50" maxlength="127" name="doc_title" class="txt" /> <cite id="do_title_word"> </cite>
<select name="doc_topic" onChange="DoAction('PutTopic');">
<option value="">- 斑竹未设置分类 - </option>
<textarea name="doc_text" style="width:100%;height:273px"> </textarea>
——————————————-
'''''''''''登陆部分代码(自动登录部分已实现)
'''''''''''''''登陆部分代码
Private Sub Command1_Click()
Dim vDoc, vTag, nTag
Dim I As Integer
On Error GoTo Line
Set vDoc = WebBrowser1.Document
For I = 0 To vDoc.All.length - 1
If UCase(vDoc.All(I).tagName) = "INPUT" Then
Set vTag = vDoc.All(I)
If vTag.Type = "text" Then
If vTag.Name <> "validate" Then vTag.Value = "t_0001" '这个是用户名
ElseIf vTag.Type = "password" Then
vTag.Value = "t_0001" '这个是密码
ElseIf vTag.Type = "submit" Then '这个是提交按钮
vTag.Click
Exit Sub
End If
End If
Next I
For I = 0 To vDoc.All.length - 1
If UCase(vDoc.All(I).tagName) = "BUTTON" Then
Set nTag = vDoc.All(I)
If nTag.Type = "submit" Then
nTag.Click
End If
End If
Next I
Sleep 3000 'ms
WebBrowser1.Navigate "http://www.xici.net/b16462/board.asp"
Line:
End Sub
——————————————-
''''''''''''''''发帖部分代码
''''''''''''''''发帖并自动提交Private Sub Command6_Click()
Dim vDoc, vTag
Dim I As Integer
On Error GoTo Line
Set vDoc = WebBrowser1.Document
For I = 0 To vDoc.All.length - 1
If UCase(vDoc.All(I).tagName) = "INPUT" Then
Set vTag = vDoc.All(I)
If vTag.Type = "textarea" Then
If vTag.Name = "doc_text" Then
vTag.Value = Text11 '要发表的帖子正文,没有实现把信息填充到正文的多行文本框内。。。
Else
End If
End If
If vTag.Type = "text" Then
If vTag.Name = "doc_title" Then vTag.Value = Text5.Text '要发表的帖子标题
ElseIf vTag.Type = "submit" Then '这个是提交按钮
vTag.Click
'''''''Exit Sub
End If
End If
Next I
'''''''For I = 0 To vDoc.All.length - 1
''''''''If UCase(vDoc.All(I).tagName) = "BUTTON" Then
''''''''Set nTag = vDoc.All(I)
''''''''If nTag.Type = "submit" Then
''''''''nTag.Click
''''''''End If
''''''''End If
''''''''Next I
WebBrowser1.Navigate "http://www.xici.net/b495265/board.asp"
Line:
End Sub
——————————————-
JC叔叔在盯着偶们哩
弄好之后共享下。。。
关注一下
可能要用到抓包工具了吧，
抓包工具还不知道怎么用呢。。。
ding…
ding…
05 28th, 2009
某网页上的文本输入框，源码如下：
文本框源码：
<INPUT class="" id=NSRLSH onkeydown=eapObjsMgr.getEAPObj(this).enterToTab()style="BORDER-TOP-WIDTH:1px;BORDER-LEFT-WIDTH:1px;BORDER-BOTTOM-WIDTH:1px;WIDTH:259px;BORDER-RIGHT-WIDTH:1px"maxlength=20 name=string(NSRLSH) JSObjName="Taxpayer" prompt="纳税人流水号" onAffirm="btnClick('changePage')' model="SWJG" isnullable="flase" isUniEAP="true">
问题：怎么自动填写数据并模拟一下回车
原来这个问题在这儿发过，有人这样回复，不过这东西不是VB的，有点儿象DELPHI或PB
//输入数据
NSRLSH.text="abc";
//模拟回车
NSRLSH.focus();
var wsh = WScript.CreateObject("WScript.Shell");
wsh.SendKeys("{ENTER}");
wsh=null;
VB应
内部网络的页面啊，互联网看不到的
这么写中不？
Dim vDoc, vTag, i
Set vDoc = WebBrowser1.Document
For i = 0 To vDoc.All.length - 1
If UCase(vDoc.All(i).tagName) = "INPUT" Then
Set vTag = vDoc.All(i)
if vtag.name="string(NSRLSH)" Then
vTag.value="123321"
SendKeys "{ENter}"
vTag.Click
end if
我写的不行啊，点了没反映
参看下面贴子，将相关的需要修改的点击语句改为赋值语句，getElementById 根据需要改为getElementsByName
我想得太简单了，我只想点击后worksheets.sheet(1).clees(i,2).copy 然后past,写时我才发觉悟，还要先找到句柄才能粘贴，真的不如将getElementsByName替换下getElementById
学习
xue xi
看看怎么样
感觉非常幸运哦，我提的总是也能被推荐！！
哈哈哈，大笑中
不要把嘴巴都笑歪了啊
/**
* 解析JSON的数据格式，并把数据绑定到显示控件
* strJson 基本格式为控件NAME:值
* @param formName json格式的对象,注意显示控件的NAME要与JSON的键名要保持一致
*/
Tools.prototype.bindFormData = function(formName, jsonObj) {
try {
var form = document.forms[formName];
for (var key in jsonObj) {
var obj = document.forms[formName].document.getElementById(key);
if (obj) {
if (obj.tagName.toLowerCase() == "select") { //是否是 下拉框
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "textarea") { //清空 textarea 的 value
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "input") { //如果是input标签
if (obj.type.toLowerCase() == "checkbox" || obj.type.toLowerCase() == "radio") { //把单选,复选置于非选中状态
var bCheck = jsonObj[key];
if ((bCheck == 1)) {
obj.checked = true;
} else {
obj.checked = false;
}
bCheck = null;
} else if ((obj.type.toLowerCase() != "button") && (obj.type.toLowerCase() != "reset")) {//清空非按钮和非重置 的所有值
obj.value = jsonObj[key];
}
}
}
}
} catch(e) {
alert("客户端绑定错误:
" + "URL:
" + this._curPage + "
message:
" + e.message);
}
};
不知道能帮你不
mark
帮你顶人气！
不知道你在做什么呢！自动填写数据不就是赋值吗？回车不就是 submit（） 一下吗？
学习
/**
* 解析JSON的数据格式，并把数据绑定到显示控件
* strJson 基本格式为控件NAME:值
* @param formName json格式的对象,注意显示控件的NAME要与JSON的键名要保持一致
*/
Tools.prototype.bindFormData = function(formName, jsonObj) {
try {
var form = document.forms[formName];
for (var key in jsonObj) {
var obj = document.forms[formName].document.getElementById(key);
if (obj) {
if (obj.tagName.toLowerCase() == "select ") { //是否是 下拉框
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "textarea ") { //清空 textarea 的 value
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "input ") { //如果是input标签
if (obj.type.toLowerCase() == "checkbox " || obj.type.toLowerCase() == "radio ") { //把单选,复选置于非选中状态
var bCheck = jsonObj[key];
if ((bCheck == 1)) {
obj.checked = true;
} else {
obj.checked = false;
}
bCheck = null;
} else if ((obj.type.toLowerCase() != "button ") && (obj.type.toLowerCase() != "reset ")) {//清空非按钮和非重置 的所有值
obj.value = jsonObj[key];
}
}
}
}
} catch(e) {
alert( "客户端绑定错误:
" + "URL:
" + this._curPage + "
message:
" + e.message);
}
};
确实好像有这问题的，谢谢分享
你这个问题只要的就是要实现模拟submit()
IE下的模拟方法：
var evt = document.createEventObject();
evt.keyCode = 13;
document.getElementById('NSRLSH').fireEvent(evt);
不错
mark!
弄不大明白
good
学习了.
05 27th, 2009
某网页上的文本输入框，源码如下：
文本框源码：
<INPUT class="" id=NSRLSH onkeydown=eapObjsMgr.getEAPObj(this).enterToTab()style="BORDER-TOP-WIDTH:1px;BORDER-LEFT-WIDTH:1px;BORDER-BOTTOM-WIDTH:1px;WIDTH:259px;BORDER-RIGHT-WIDTH:1px"maxlength=20 name=string(NSRLSH) JSObjName="Taxpayer" prompt="纳税人流水号" onAffirm="btnClick('changePage')' model="SWJG" isnullable="flase" isUniEAP="true">
问题：怎么自动填写数据并模拟一下回车
原来这个问题在这儿发过，有人这样回复，不过这东西不是VB的，有点儿象DELPHI或PB
//输入数据
NSRLSH.text="abc";
//模拟回车
NSRLSH.focus();
var wsh = WScript.CreateObject("WScript.Shell");
wsh.SendKeys("{ENTER}");
wsh=null;
VB应
内部网络的页面啊，互联网看不到的
这么写中不？
Dim vDoc, vTag, i
Set vDoc = WebBrowser1.Document
For i = 0 To vDoc.All.length - 1
If UCase(vDoc.All(i).tagName) = "INPUT" Then
Set vTag = vDoc.All(i)
if vtag.name="string(NSRLSH)" Then
vTag.value="123321"
SendKeys "{ENter}"
vTag.Click
end if
我写的不行啊，点了没反映
参看下面贴子，将相关的需要修改的点击语句改为赋值语句，getElementById 根据需要改为getElementsByName
我想得太简单了，我只想点击后worksheets.sheet(1).clees(i,2).copy 然后past,写时我才发觉悟，还要先找到句柄才能粘贴，真的不如将getElementsByName替换下getElementById
学习
xue xi
看看怎么样
感觉非常幸运哦，我提的总是也能被推荐！！
哈哈哈，大笑中
不要把嘴巴都笑歪了啊
/**
* 解析JSON的数据格式，并把数据绑定到显示控件
* strJson 基本格式为控件NAME:值
* @param formName json格式的对象,注意显示控件的NAME要与JSON的键名要保持一致
*/
Tools.prototype.bindFormData = function(formName, jsonObj) {
try {
var form = document.forms[formName];
for (var key in jsonObj) {
var obj = document.forms[formName].document.getElementById(key);
if (obj) {
if (obj.tagName.toLowerCase() == "select") { //是否是 下拉框
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "textarea") { //清空 textarea 的 value
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "input") { //如果是input标签
if (obj.type.toLowerCase() == "checkbox" || obj.type.toLowerCase() == "radio") { //把单选,复选置于非选中状态
var bCheck = jsonObj[key];
if ((bCheck == 1)) {
obj.checked = true;
} else {
obj.checked = false;
}
bCheck = null;
} else if ((obj.type.toLowerCase() != "button") && (obj.type.toLowerCase() != "reset")) {//清空非按钮和非重置 的所有值
obj.value = jsonObj[key];
}
}
}
}
} catch(e) {
alert("客户端绑定错误:
" + "URL:
" + this._curPage + "
message:
" + e.message);
}
};
不知道能帮你不
mark
帮你顶人气！
不知道你在做什么呢！自动填写数据不就是赋值吗？回车不就是 submit（） 一下吗？
学习
/**
* 解析JSON的数据格式，并把数据绑定到显示控件
* strJson 基本格式为控件NAME:值
* @param formName json格式的对象,注意显示控件的NAME要与JSON的键名要保持一致
*/
Tools.prototype.bindFormData = function(formName, jsonObj) {
try {
var form = document.forms[formName];
for (var key in jsonObj) {
var obj = document.forms[formName].document.getElementById(key);
if (obj) {
if (obj.tagName.toLowerCase() == "select ") { //是否是 下拉框
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "textarea ") { //清空 textarea 的 value
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "input ") { //如果是input标签
if (obj.type.toLowerCase() == "checkbox " || obj.type.toLowerCase() == "radio ") { //把单选,复选置于非选中状态
var bCheck = jsonObj[key];
if ((bCheck == 1)) {
obj.checked = true;
} else {
obj.checked = false;
}
bCheck = null;
} else if ((obj.type.toLowerCase() != "button ") && (obj.type.toLowerCase() != "reset ")) {//清空非按钮和非重置 的所有值
obj.value = jsonObj[key];
}
}
}
}
} catch(e) {
alert( "客户端绑定错误:
" + "URL:
" + this._curPage + "
message:
" + e.message);
}
};
确实好像有这问题的，谢谢分享
05 26th, 2009
某网页上的文本输入框，源码如下：
文本框源码：
<INPUT class="" id=NSRLSH onkeydown=eapObjsMgr.getEAPObj(this).enterToTab()style="BORDER-TOP-WIDTH:1px;BORDER-LEFT-WIDTH:1px;BORDER-BOTTOM-WIDTH:1px;WIDTH:259px;BORDER-RIGHT-WIDTH:1px"maxlength=20 name=string(NSRLSH) JSObjName="Taxpayer" prompt="纳税人流水号" onAffirm="btnClick('changePage')' model="SWJG" isnullable="flase" isUniEAP="true">
问题：怎么自动填写数据并模拟一下回车
原来这个问题在这儿发过，有人这样回复，不过这东西不是VB的，有点儿象DELPHI或PB
//输入数据
NSRLSH.text="abc";
//模拟回车
NSRLSH.focus();
var wsh = WScript.CreateObject("WScript.Shell");
wsh.SendKeys("{ENTER}");
wsh=null;
VB应
内部网络的页面啊，互联网看不到的
这么写中不？
Dim vDoc, vTag, i
Set vDoc = WebBrowser1.Document
For i = 0 To vDoc.All.length - 1
If UCase(vDoc.All(i).tagName) = "INPUT" Then
Set vTag = vDoc.All(i)
if vtag.name="string(NSRLSH)" Then
vTag.value="123321"
SendKeys "{ENter}"
vTag.Click
end if
我写的不行啊，点了没反映
参看下面贴子，将相关的需要修改的点击语句改为赋值语句，getElementById 根据需要改为getElementsByName
我想得太简单了，我只想点击后worksheets.sheet(1).clees(i,2).copy 然后past,写时我才发觉悟，还要先找到句柄才能粘贴，真的不如将getElementsByName替换下getElementById
学习
xue xi
看看怎么样
感觉非常幸运哦，我提的总是也能被推荐！！
哈哈哈，大笑中
不要把嘴巴都笑歪了啊
/**
* 解析JSON的数据格式，并把数据绑定到显示控件
* strJson 基本格式为控件NAME:值
* @param formName json格式的对象,注意显示控件的NAME要与JSON的键名要保持一致
*/
Tools.prototype.bindFormData = function(formName, jsonObj) {
try {
var form = document.forms[formName];
for (var key in jsonObj) {
var obj = document.forms[formName].document.getElementById(key);
if (obj) {
if (obj.tagName.toLowerCase() == "select") { //是否是 下拉框
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "textarea") { //清空 textarea 的 value
obj.value = jsonObj[key];
} else if (obj.tagName.toLowerCase() == "input") { //如果是input标签
if (obj.type.toLowerCase() == "checkbox" || obj.type.toLowerCase() == "radio") { //把单选,复选置于非选中状态
var bCheck = jsonObj[key];
if ((bCheck == 1)) {
obj.checked = true;
} else {
obj.checked = false;
}
bCheck = null;
} else if ((obj.type.toLowerCase() != "button") && (obj.type.toLowerCase() != "reset")) {//清空非按钮和非重置 的所有值
obj.value = jsonObj[key];
}
}
}
}
} catch(e) {
alert("客户端绑定错误:
" + "URL:
" + this._curPage + "
message:
" + e.message);
}
};
不知道能帮你不
05 17th, 2009
南宁新时空网 http://www.nn-sky.com/
用户名：一天一个梦 密码：000000
你登陆进去，，就有一个3级联动，，，城市 城区 片区
有哪位高手，，请帮帮忙，，谢谢 了，，，
菜鸟只有20分，，5555555.。。。。
孩子又在这里了啊
3级联动,无非就是要等待联动的脚本（或从服务器上获取）运行完成后，再进行选择
如果你能搜索到我以前回答过的，应该可以考虑一下
我晕，登录有图片验证，俺干不了！！
我想问下什么是三级联动？
就是说，，必须要选择 “城市” 之后，，才能选择 “城区” ，，，选择 区域 之后才能选择 “片区”
我只有20分，，，55555，，，有人不嫌分数低而帮助我吗？？？？
继续等待高手的出现，，，
04 25th, 2009
我的工程有driveListBox,DirListBox,FileListBox控件,当我启动了我程序以后,再插入一移动磁盘(或移动硬盘),请问如何将它自动添加到dirveListBox控件的列表上去.大家帮忙看下
开始也想到,哎,就是头脑不会转一下,多谢chenjl1031 的回复,很及时.
请问用drivelistbox控件的什么事件来触发自动添加啊,到不到补充一下,在哪个事件加drive1.refresh最合适啊,最好不要加timer控件
Private Sub Drive1_GotFocus()
Drive2.Refresh
End Sub
这样做好似第一次选时选不中文件,要第二次才出现的
drivelistbox控件所有事件都要人工触发,自动触发就要时间控件
04 16th, 2009
我要做一个查询,设计是这样的:用一个COMBOL空件,可以在此控件里查找已添加的数据库记录.但是我又想实现手动输入时,输入一部分字符,就自动过滤了不相符合的数据,只留下符合的数据记录.如数据库有20091101,20081099,20091111等数据,我在COMBOL里输入2009时,就只显示20091101,20091111了,过滤了20081099.不知道我描述清楚没有!可以加我QQ:158372430
不知你在 Combo 中列表数量有多少。如果列表较大，每输入一个字符就清空并重写列表，或者每输入一个字符就遍历删除不匹配列表项，都会使输入感觉迟滞。
所以，可能更好的方法是动态定位。例如，将你的所有列表排序，当快速输入一串字符后，控件代码会下拉定位到第一个匹配位置。
如果你采用这种方法，我可以贴出代码。
楼主要求的是只显示，所以按这要求必须重新清空。
不过2楼说的方法也很好，同样是keypress事件，更改combo的listindex
按娘需求，可以这样。但列表项不要太多。
Option Explicit
Private Declare Function SendMessagebyString Lib "user32" Alias "SendMessageA" (ByVal hWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const LB_FINDSTRING = &H18F '在 ListBox 中模糊查找
Private Sub Combo1_Change()
Dim lngIndex As Long, lngStarting As Long, lngFirstMatch As Long, i As Integer
Do Until Combo1.ListCount = 0
Combo1.RemoveItem 0
Loop
lngFirstMatch = SendMessagebyString(List1.hWND, LB_FINDSTRING, -1, Combo1.Text)
lngStarting = lngFirstMatch
lngIndex = -1
Do Until lngIndex = lngFirstMatch
Combo1.AddItem List1.List(lngStarting)
lngIndex = SendMessagebyString(List1.hWND, LB_FINDSTRING, lngStarting, Combo1.Text)
lngStarting = lngIndex
Loop
End Sub
Private Sub Form_Load()
Dim i As Integer
List1.AddItem "20090303"
List1.AddItem "20090403"
List1.AddItem "20080403"
List1.Visible = False
For i = 0 To List1.ListCount - 1
Combo1.AddItem List1.List(i)
Next i
End Sub
感谢各位了.问题已经解决了.
Option Explicit
Private hMainMenu As Long '主菜单
Private hFirstLevelMenu() As Long '一级菜单
Private hSecondLevelMenu As Long '二级菜单
Private hThirdLevelMenu As Long '三级菜单
Private intMenuCount As Integer '菜单总数
Private arrMenuList() As String '菜单信息列表数组
Private lngWinProc As Long
Private Const MF_POPUP = &H10
Private Const MF_STRING = &H0
Private Const MF_SEPARATOR = &H800
Private Const MF_BYPOSITION = &H400
Private Const WM_COMMAND = &H111
Private Const GWL_WNDPROC = (-4)
Public Xwx As New Class1
Public R1 As Recordset
'创建菜单API函数
Private Declare Function CreateMenu Lib "User32" () As Long
'创建弹出式菜单API函数
Private Declare Function CreatePopupMenu Lib "User32" () As Long
'插入菜单项API函数
Private Declare Function InsertMenu Lib "User32" Alias "InsertMenuA" _
(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
'追加菜单项API函数
Private Declare Function AppendMenu Lib "User32" Alias "AppendMenuA" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
'修改菜单项API函数
Private Declare Function ModifyMenu Lib "User32" Alias "ModifyMenuA" _
(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
'设定菜单到对象上API函数
Private Declare Function SetMenu Lib "User32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
'在对象上画菜单条API函数
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
'获取一个窗口的菜单句柄
Private Declare Function GetMenu Lib "User32" (ByVal hwnd As Long) As Long
'获取子菜单句柄
Private Declare Function GetSubMenu Lib "User32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
'删除菜单控件, 释放资源
Private Declare Function DestroyMenu Lib "User32" (ByVal hMenu As Long) As Long
'在窗口结构中为指定的窗口设置信息
Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'从指定窗口的结构中获得信息
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'调用窗口事件处理
Private Declare Function CallWindowProc Lib "User32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Sub main()
Form1.Show
End Sub
'自动创建菜单过程
Public Sub AutoCreateMenu(frmName As Form)
Dim i As Integer, j As Integer, k As Integer, intTopMenuCount As Integer
Dim wFlags As Long
'建立主菜单
hMainMenu = GetMenu(frmName.hwnd)
If hMainMenu = 0 Then Exit Sub
'从数据库菜单表中取出信息初始化菜单数组
Call InitMenuArray
ReDim hFirstLevelMenu(intMenuCount)
'建立一级菜单 TODO 循环优化
For i = 1 To intMenuCount
If arrMenuList(3, i) = "1" Then
'取得一个弹出式菜单的句柄。
hFirstLevelMenu(i) = CreatePopupMenu()
'为主菜单添加菜单项及添加Caption属性并指定为弹出式菜单属性。
AppendMenu hMainMenu, MF_POPUP Or MF_BYPOSITION Or MF_STRING, hFirstLevelMenu(i), arrMenuList(2, i)
intTopMenuCount = intTopMenuCount + 1
End If
Next i
'建立二级菜单
For i = 1 To intMenuCount
If arrMenuList(3, i) = "2" Then
If arrMenuList(2, i) = "-" Then
wFlags = MF_SEPARATOR Or MF_BYPOSITION
Else
wFlags = MF_STRING Or MF_BYPOSITION
End If
For j = 1 To intMenuCount
If arrMenuList(5, i) = arrMenuList(1, j) Then 'i循环菜单的上级菜单编号=j循环菜单的菜单编号
hSecondLevelMenu = GetSubMenu(hMainMenu, arrMenuList(4, j))
'建立三级菜单
If arrMenuList(6, i) = "0" Then 'END_MENU_FLAG=0 表示还有下属子菜单
'取得一个弹出式菜单的句柄。
hThirdLevelMenu = CreatePopupMenu()
For k = 1 To intMenuCount
If arrMenuList(5, k) = arrMenuList(1, i) Then 'k循环菜单的上级菜单编号=i循环菜单的菜单编号
AppendMenu hThirdLevelMenu, wFlags, arrMenuList(1, k), arrMenuList(2, k)
End If
Next k
AppendMenu hSecondLevelMenu, wFlags Or MF_POPUP, hThirdLevelMenu, arrMenuList(2, i)
Else
AppendMenu hSecondLevelMenu, wFlags, arrMenuList(1, i), arrMenuList(2, i)
End If
End If
Next j
End If
Next i
'将主菜单设置给本窗口。
SetMenu frmName.hwnd, hMainMenu
'响应API创建成的菜单单击事件
lngWinProc = GetWindowLong(frmName.hwnd, GWL_WNDPROC)
'SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
End Sub
'响应API创建成的菜单单击事件
Private Function ClickMenu(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case wMsg
Case WM_COMMAND
Select Case wParam
Case 900204
frmSysUser.Show
Case 900205
frmSysRole.Show
Case 900210
Unload frmMain
End Select
End Select
ClickMenu = CallWindowProc(lngWinProc, hwnd, wMsg, wParam, lParam)
End Function
'获取系统菜单总个数
Private Function GetMenuCount() As Integer
Dim rsMenu As New ADODB.Recordset
Dim gsSql As String
gsSql = "SELECT COUNT(*) CNT FROM SYS_MENU"
If DBQuerySQL(rsMenu, gsSql) = 1 Then
GetMenuCount = rsMenu("CNT").Value
Else
GetMenuCount = 0
End If
rsMenu.Close
End Function
'菜单数组赋值
Function InitMenuArray()
Dim i As Integer
Dim rsMenu As New ADODB.Recordset
Dim gsSql As String
'MenuArray数组描述
'第一维按顺序分别存放 菜单编号、菜单名称、菜单层级、菜单显示顺序、上级菜单、是否末级菜单、菜单对应窗体名、菜单操作权限
intMenuCount = GetMenuCount()
ReDim arrMenuList(1 To 8, 1 To intMenuCount)
'gsSql = "SELECT " & _
"MENU_NO," & _
"MENU_NAME," & _
"MENU_LEVEL," & _
"MENU_SEQ," & _
"PARENT_MENU," & _
"END_MENU_FLAG," & _
"EXEC_FORM," & _
"'1' MENU_PVG" & _
" FROM SYS_MENU " & _
" ORDER BY MENU_NO,MENU_SEQ"
gsSql = "SELECT " & _
"sys_MENU_1," & _
"sys_MENU_2," & _
"sys_MENU_3," & _
"sys_MENU_4," & _
"sys_MENU_5," & _
"sys_MENU_6," & _
"sys_MENU_7," & _
"'0' sys_MENU_8" & _
" FROM SYS_MENU " & _
" ORDER BY sys_MENU_1,sys_MENU_4"
If DBQuerySQL(rsMenu, gsSql) <> -1 Then
For i = 1 To rsMenu.RecordCount
arrMenuList(1, i) = rsMenu("sys_MENU_1").Value
arrMenuList(2, i) = rsMenu("sys_MENU_2").Value
arrMenuList(3, i) = rsMenu("sys_MENU_3").Value
arrMenuList(4, i) = rsMenu("sys_MENU_4").Value
arrMenuList(5, i) = rsMenu("sys_MENU_5").Value
arrMenuList(6, i) = rsMenu("sys_MENU_6").Value
arrMenuList(7, i) = rsMenu("sys_MENU_7").Value
arrMenuList(8, i) = rsMenu("sys_MENU_8").Value
rsMenu.MoveNext
Next i
End If
rsMenu.Close
End Function
那位老师可以决绝这个，问题
程序运行到：
SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
vb就自动关闭了，不知道问题出在哪儿，在线求助！
问题已近解决，明天结贴，谢谢各位。
ClickMenu参数问题？
还是有问题，
Case WM_COMMAND
Select Case wParam
Case 900204
‘’ frmSysUser.Show
Case 900205
‘’ frmSysRole.Show
Case 900210
‘’ Unload frmMain
End Select
单引号后面不用就可以，去掉单引号就自动退出VB
人呢？
问题解决，是参数回调错误。
01 11th, 2009
我的程序需求是这样的：
(1）在网络服务器a下监控若干个.txt文件和.dat文件，监控路径为sys－ddmsg－tv，若干个.txt文件和.dat文件的文件名都包含当天的日期，例如：今天监控的文件是
“生活1215.txt”和“生活1215.dat”，明天监控的文件则是“生活1216.txt”和“生活1216.dat”。
一旦这些文件上传到网络服务器a，则对.txt文件进行打印，每个文件打印2份；同时把.dat文件复制到本机的某个目录下的某个文件夹内。
(2)在网络服务器b下监控文件，监控路径为benn－ddmsg－yszx，一旦这些文件上传到网络服务器b，则对.txt文件进行打印，每个文件打印2份；同时把.dat文件复制到本机的某个目录下的某个文件夹内。
（3）对已经复制到本机的.dat文件进行字符串检查（.dat文件的内容全部是由阿拉伯数字构成），字符串的格式为“00000”，字符串的标识是开头是“0”的字符串，对开头是“0”的字符串进行检查，遇到“02121”，“02323”“02222”“00723”“00722”的字符串，则更正为“00708”“00910”“00809”“00710”“00709”。
程序叫做“文件自动监控与电码文件自动订正系统”。
各位大侠帮帮忙。我真是无从下手，时间又紧，压力太大！
做一个自动监控就可以了！到网上找找监控文件夹改动的源代码，修改一下就可以了，不难！
不是免费拉，我有说免费帮我做吗？只是希望大家给点建议拉
01 8th, 2009
我现在有个问题，我在做一个大于8byte 的数据变量累加，把结果转换成16进制显示的时候，用HEX是不行的，因为HEX最多8byte，问题是计算机本来就是HEX运算的，
何必让VB把它自动转换成10进制，然后我再转换成16进制，是不是多此一举呢？有没有办法直接把变量的 16进制数据直接提出来显示？
回楼上，我说的不是 字符串变成数字运算，我说的是 从BIN文档中通过二进制方法读出来的，已经在运算了，所以不存在字符ASCII的问题，我要的是最后的结果能直接变成ASCII字符串显示就好了，但是目前的方法是首先要把十进制变成16进制，然后再变成字符串运算，因为在内存中是2进制的，每4个BIT就是一个HEX的位，我们在写汇编的时候一般都是按照16进制运算的，反而要变成10进制要通过函数转换，所以我们应该可以直接把变量里边的二进制数读出来，比如一个BYTE最大就是255，也就是FF，但是VB显示给我们都是255，而不是2进制或者16进制，说明已经给了转换。我就是想不要这种自动转换。 直接读出数值转换成字符就快速多了。
我刚才看了一下MSDN
Hex 函数
返回代表十六进制数值的 String。
原来是返回的字符串，原来如此，我都当作数据了，
实际上不管你什么进制的只是显示方便的问题。
实际上电脑都是用2进制运算的。