VB 获取所有窗体菜单信息
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
BackColor = &H00C0C0C0&
BorderStyle = 1 'Fixed Single
Caption = "?????"
ClientHeight = 7215
ClientLeft = 45
ClientTop = 435
ClientWidth = 12180
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 7215
ScaleWidth = 12180
StartUpPosition = 3 'Windows Default
Begin VB.TextBox Text1
Height = 1095
Left = 600
MultiLine = -1 'True
TabIndex = 4
Top = 720
Width = 5535
End
Begin MSComctlLib.ListView ListView1
Height = 5055
Left = 120
TabIndex = 3
Top = 240
Width = 11655
_ExtentX = 20558
_ExtentY = 8916
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 3480
Top = 5520
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Command2
BackColor = &H00C0C0C0&
Caption = "All"
Height = 615
Left = 8040
Style = 1 'Graphical
TabIndex = 1
Top = 5640
Width = 1935
End
Begin VB.CommandButton Command1
BackColor = &H00C0C0C0&
Caption = "get menus from file(*.frm)"
Height = 735
Left = 5040
Style = 1 'Graphical
TabIndex = 0
Top = 5640
Width = 2175
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "MADE BY ANJIAN"
BeginProperty Font
Name = "Tahoma"
Size = 14.25
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00E0E0E0&
Height = 285
Left = 120
TabIndex = 2
Top = 5700
Width = 2310
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const sFolder = "D:\projectVB6\Test"
Dim str As String
Dim strAll As String Private Sub Command1_Click()
On Error GoTo 1
Dim sCaption As String
sCaption = ""
str = ""
ListView1.ListItems.Clear
Dim i As Integer
Dim pos As Integer
Dim count As Integer
Dim spacelen As Integer
Dim freenum As Integer
freenum = FileSystem.FreeFile
With CommonDialog1
.Filter = "*.frm|*.frm"
.FileName = ""
.ShowOpen
If Trim(.FileName) = "" Then
Exit Sub
End If
Open .FileName For Input As freenum
Do While Not EOF(freenum)
i = i + 1
Line Input #freenum, str
pos = InStr(1, str, "Begin VB.Menu", vbTextCompare) '?????
If pos > 0 Then
count = count + 1
spacelen = ((pos - 1) \ 3 - 1) * 4
ListView1.ListItems.Add , "name" & count, Space(spacelen) & Trim(Right(str, Len(str) - pos - 12))
ListView1.ListItems.Item(count).ListSubItems.Add , "caption" & count, ""
ListView1.ListItems.Item(count).ListSubItems.Add , "index" & count, ""
ListView1.ListItems.Item(count).ListSubItems.Add , "Checked" & count, "False"
ListView1.ListItems.Item(count).ListSubItems.Add , "Enabled" & count, "True"
ListView1.ListItems.Item(count).ListSubItems.Add , "Visible" & count, "True"
End If pos = InStr(1, str, "Caption", vbTextCompare) '????
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("caption" & count).Text = Space(spacelen) & Replace(Trim(Right(str, Len(str) - pos - 16)), """", "")
sCaption = ListView1.ListItems.Item(count).ListSubItems("caption" & count).Text
sCaption = Replace(sCaption, "&", "")
If Trim(sCaption) <> "-" Then
Text1.Text = Text1 & sCaption & vbCrLf
End If End If
End If
GoTo lbEnd pos = InStr(1, str, "Index", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("index" & count).Text = Space(spacelen) & Trim(Right(str, Len(str) - pos - 16))
End If
End If
pos = InStr(1, str, "Checked", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("Checked" & count).Text = Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")
End If
End If
pos = InStr(1, str, "Enabled", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("Enabled" & count).Text = Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")
End If
End If pos = InStr(1, str, "Visible", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("Visible" & count).Text = Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")
'fliter visible false
If Trim(Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")) = "False" Then
'ListView1.ListItems.Item(count).ListSubItems("caption" & count).Text = ""
End If
End If
End If lbEnd: If InStr(1, str, "Attribute VB_Name", vbTextCompare) > 0 Then
Exit Do
End If
Loop
Close freenum
End With Exit Sub
1: End Sub Private Sub getMenu(ByVal sFileName As String)
On Error GoTo 1
Dim sCaption As String
Dim sCap As String
sCap = ""
sCaption = ""
str = ""
' strAll = strAll & sFileName & vbCrLf
ListView1.ListItems.Clear
Dim i As Integer
Dim pos As Integer
Dim count As Integer
Dim spacelen As Integer
Dim freenum As Integer
freenum = FileSystem.FreeFile
Open sFileName For Input As freenum
Do While Not EOF(freenum)
i = i + 1
Line Input #freenum, str
pos = InStr(1, str, "Begin VB.Menu", vbTextCompare) '?????
If pos > 0 Then
count = count + 1
spacelen = ((pos - 1) \ 3 - 1) * 4
ListView1.ListItems.Add , "name" & count, Space(spacelen) & Trim(Right(str, Len(str) - pos - 12))
ListView1.ListItems.Item(count).ListSubItems.Add , "caption" & count, ""
ListView1.ListItems.Item(count).ListSubItems.Add , "index" & count, ""
ListView1.ListItems.Item(count).ListSubItems.Add , "Checked" & count, "False"
ListView1.ListItems.Item(count).ListSubItems.Add , "Enabled" & count, "True"
ListView1.ListItems.Item(count).ListSubItems.Add , "Visible" & count, "True"
End If pos = InStr(1, str, "Caption", vbTextCompare) '????
If pos > 0 Then
If count > 0 Then
' ListView1.ListItems.Item(count).ListSubItems("caption" & count).Text = Space(spacelen) & Replace(Trim(Right(str, Len(str) - pos - 16)), """", "")
sCap = Space(spacelen) & Replace(Trim(Right(str, Len(str) - pos - 16)), """", "")
sCap = Replace(sCap, "&", "")
If Trim(sCap) <> "-" Then
'Text1.Text = Text1 & sCaption & vbCrLf
sCaption = sCaption & sCap & vbCrLf
End If End If
End If
GoTo lbEnd pos = InStr(1, str, "Index", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("index" & count).Text = Space(spacelen) & Trim(Right(str, Len(str) - pos - 16))
End If
End If
pos = InStr(1, str, "Checked", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("Checked" & count).Text = Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")
End If
End If
pos = InStr(1, str, "Enabled", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("Enabled" & count).Text = Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")
End If
End If pos = InStr(1, str, "Visible", vbTextCompare) '??
If pos > 0 Then
If count > 0 Then
ListView1.ListItems.Item(count).ListSubItems("Visible" & count).Text = Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")
'fliter visible false
If Trim(Replace(Trim(Right(str, Len(str) - pos - 21)), "'", "")) = "False" Then
'ListView1.ListItems.Item(count).ListSubItems("caption" & count).Text = ""
End If
End If
End If lbEnd: If InStr(1, str, "Attribute VB_Name", vbTextCompare) > 0 Then
Exit Do
End If
Loop
Close freenum ' strAll = "****************************************************************" & vbCrLf & Replace(sFileName, "D:\Git working\Hytek\SWMM7\", "") & vbCrLf & strAll If Trim(sCaption) <> "" Then
sCaption = "****************************************************************" & vbCrLf & Replace(sFileName, sFolder & "\", "") & vbCrLf & sCaption
End If
strAll = strAll & sCaption & vbCrLf Exit Sub
1:
MsgBox Err.Description
End Sub Private Sub Command2_Click()
Dim cnt As Integer, i As Integer
Dim fso As Object
Dim folder As Object
Dim subfolder As Object
Dim file As Object
Set fso = CreateObject("scripting.filesystemobject") Set folder = fso.getfolder(sFolder) ' get all files in folder For Each file In folder.Files
If (Right(file, 4) = ".frm") Then
cnt = cnt + 1
End If
Next For Each file In folder.Files If (Right(file, 4) = ".frm") Then
'MsgBox file
getMenu (file)
i = i + 1
Caption = file & " done." & i & "/" & cnt
End If
Next
Set file = fso.CreateTextFile("c:\MMMenu-All.txt", True)
file.Write strAll
file.Close
Set fso = Nothing
Set folder = Nothing Text1.Text = strAll End Sub Private Sub Form_Load()
With ListView1
.View = lvwReport
.ColumnHeaders.Add , "name", "name"
.ColumnHeaders.Add , "caption", "caption"
.ColumnHeaders.Add , "index", "index"
.ColumnHeaders.Add , "Checked", "Checked"
.ColumnHeaders.Add , "Enabled", "Enabled"
.ColumnHeaders.Add , "Visible", "Visible"
End With
SaveSetting "VBMenus", "path", "filename", App.Path & "\" & App.EXEName
End Sub
'*************************************************************************
'*************************************************************************
Private Sub toword(ByVal rowcount As Integer, ByVal fieldscount As Integer)
On Error Resume Next
If rowcount > 0 Then
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim atable As Word.Table
Dim i As Integer, j As Integer
Set wdapp = New Word.Application
Set wddoc = wdapp.Documents.Add
With wdapp
.Visible = True
.Activate
Set atable = .ActiveDocument.Tables.Add(.Selection.Range, rowcount + 1, fieldscount)
For i = 1 To fieldscount
atable.Cell(1, i).Range.InsertAfter ListView1.ColumnHeaders(i)
Next i For i = 1 To rowcount
atable.Cell(i + 1, 1).Range.InsertAfter ListView1.ListItems(i).Text
atable.Cell(i + 1, 2).Range.InsertAfter ListView1.ListItems(i).ListSubItems(1).Text
atable.Cell(i + 1, 3).Range.InsertAfter ListView1.ListItems(i).ListSubItems(2).Text
atable.Cell(i + 1, 4).Range.InsertAfter ListView1.ListItems(i).ListSubItems(3).Text
atable.Cell(i + 1, 5).Range.InsertAfter ListView1.ListItems(i).ListSubItems(4).Text
atable.Cell(i + 1, 6).Range.InsertAfter ListView1.ListItems(i).ListSubItems(5).Text
Next i
End With
'??word??
Set atable = Nothing
Set wdapp = Nothing
Set wddoc = Nothing
Else
MsgBox "err", vbCritical
End If
End Sub
VB 获取所有窗体菜单信息的更多相关文章
- asp.net C#获取程序文件相关信息
代码如下 复制代码 using System.Reflection;using System.Runtime.CompilerServices; //// 有关程序集的常规信息是通过下列// 属性集控 ...
- C++通过WIN32 API获取逻辑磁盘详细信息
众所周知,在微软的操作系统下编写应用程序,最主要的还是通过windows所提供的api函数来实现各种操作的,这些函数通常是可以直接使用的,只要包含windows.h这个头文件. 今天我们主要介绍的 ...
- 获取Winform窗体、工作区 宽度、高度、命名空间、菜单栏高度等收集
MessageBox.Show("当前窗体标题栏高"+(this.Height - this.ClientRectangle.Height).ToString());//当前窗体标 ...
- php递归获取无限分类菜单
从数据库获取所有菜单信息,需要根据id,pid字段获取主菜单及其子菜单,以及子菜单下的子菜单,可以通过函数递归来实现. <?php class Menu { public $menu = arr ...
- MFC获取各个窗体(体)之间的指针(对象)
MFC在非常多的对话框操作中,我们常常要用到在一个对话框中调用还有一个对话框的函数或变量.能够用例如以下方法来解决. HWND hWnd=::FindWindow(NULL,_T("S ...
- Dynamics 365客户端编程示例：获取当前用户的信息，表单级通知/提示，表单OnLoad事件执行代码
我是微软Dynamics 365 & Power Platform方面的工程师罗勇,也是2015年7月到2018年6月连续三年Dynamics CRM/Business Solutions方面 ...
- Qt网络获取本机网络信息
下面我们就讲解如何获取自己电脑的IP地址以及其他网络信息.这一节中,我们会涉及到网络模块(QtNetwork Module)中的QHostInfo ,QHostAddress ,QNetworkInt ...
- 使用PHP获取图像文件的EXIF信息
在我们拍的照片以及各类图像文件中,其实还保存着一些信息是无法直观看到的,比如手机拍照时会有的位置信息,图片的类型.大小等,这些信息就称为 EXIF 信息.一般 JPG . TIFF 这类的图片文件都会 ...
- 调用手机在线API获取手机号码归属地信息
手机在线(www.showji.com)始创于2001年,发展至今已拥有国内最准确.号段容量最大的手机号码归属地数据库系统, 目前号段容量将近33万条,每月保持两次以上规模数据更新,合作伙伴包括:百度 ...
随机推荐
- 【Luogu P2201】【JZOJ 3922】数列编辑器
题面: Description 小Z是一个爱好数学的小学生.最近,他在研究一些关于整数数列的性质. 为了方便他的研究,小Z希望实现一个叫做"Open Continuous Lines Pro ...
- 微信JSSdk实现分享功能
1. 概述 微信分享服务器的作用是为用户在微信浏览器端对来自网站以及客户端的页面进行二次分享链接时更友好的展示提供服务.为实现二次分享功能需要使用微信JS-SDK来开发. 微信JS-SDK是微信公众平 ...
- tcp和udp详解？？
TCP:面向连接的可靠传输 tcp规定了:传输服务必须建立连接 传输结束必须断开连接 传输数据必须保证可靠 数据的可靠性:无重复.无丢失.无失序.无差错. 建立连接(三次握手): ...
- UVA 11354 Bond 最小生成树 + lca
题意 给出一张图,q个询问,每次询问给出uv,找出一条路径,使这条路径上的最大边权是两点所有路径中最小,输出这个值 思路 很显然要先求出最小生成树,任意两点在最小生成树上有唯一路径,并且这条路径上的最 ...
- 深入了解RabbitMQ工作原理及简单使用
深入了解RabbitMQ工作原理及简单使用 RabbitMQ系列文章 RabbitMQ在Ubuntu上的环境搭建 深入了解RabbitMQ工作原理及简单使用 RabbitMQ交换器Exchange介绍 ...
- LeetCode-239-剑指offer-滑动窗口的最大值-队列与栈-python
给定一个数组和滑动窗口的大小,找出所有滑动窗口里数值的最大值.例如,如果输入数组{2,3,4,2,6,2,5,1}及滑动窗口的大小3,那么一共存在6个滑动窗口,他们的最大值分别为{4,4,6,6,6, ...
- C# 静态方法调用非静态方法
转载:http://blog.csdn.net/seattle1215/article/details/6657814 using System; using System.Collections.G ...
- 移动前端不得不了解的Meta标签
http://ghmagical.com/article/page/id/PSeJR0rPd34k
- jQuery进阶第四天（2019 10.13）
1 初识面向对象(面向对象是一种思维方式) 以前写的代码 var name = '莉莉'; var sex = '女'; var age = 18; var name1 = '小明'; var sex ...
- 如何让css隐藏滚动条 兼容谷歌、火狐、IE等各个浏览器
项目中,页面效果需要展示一个页面的移动端效果,使用的是一个苹果手机样式背景图,咋也没用过苹果,咋也不敢形容. 如下图所示: 在谷歌浏览器如图一滚动条顺利隐藏,但是火狐就如图二了,有了滚动条丑的一批. ...