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万条,每月保持两次以上规模数据更新,合作伙伴包括:百度 ...
随机推荐
- Django、Flask、Tornado的区别?
Django:Python 界最全能的 web 开发框架,battery-include 各种功能完备,可维护性和开发速度一级棒.常有人说 Django 慢,其实主要慢在 Django ORM 与数据 ...
- 阿里云服务器重启出现An error occurred 如何处理
最近网站重启阿里云服务后,出现 An error occurred, An error occurred. Sorry, the page you are looking for is current ...
- angularJS(一):表达式、指令
简介 以 JavaScript 编写的库,是一个 JavaScript 框架 一.表达式 AngularJS 使用 表达式 把数据绑定到 HTML. 表达式写在双大括号内:{{ expression ...
- Kibana 基本操作
es中的索引对应mysql的数据库.类型对应mysql的表.文档对应mysql的记录.映射对应mysql的索引索引:index类型:type映射:mappings 1.创建索引在kibana的Dev ...
- linux 深入应用 NFS
以下实验大家用主机名来区分服务器端和客户端, 服务器端为 NFS_Server ip-192.168.1.4: 客户端为 NFS_Client ip-192.168.1.5: 实例一 将/tmp 分享 ...
- ubuntu上的疑难杂症(不定期更新……)
ubuntu系统英伟达显卡驱动怎么装 sudo apt-get purge nvidia* #如果之前安装过显卡驱动,就执行这一句来卸载 sudo apt-add-repository ppa:gra ...
- CentOS7 安装 Mysql5.6.40
CentOS7.5二进制安装MySQL-5.6.40 安装之后登陆不上,mysql.user 表是空的时: Mysql User表为空 mysql创建用户报错ERROR 1364 (HY000): F ...
- Java并发——原子变量和原子操作
很多情况下我们只是需要一个简单的.高效的.线程安全的递增递减方案.注意,这里有三个条件:简单,意味着程序员尽可能少的操作底层或者实现起来要比较容易:高效意味着耗用资源要少,程序处理速度要快:线程安全也 ...
- GUI学习之二十五——QFontDialog学习总结
今天学习字体对话框——QFontDialog()控件. QFontDialog()是继承自QDialog()的一个子类,用来选择给定的字体(包括字体.字号.样式等) 一.构造函数 QFontDialo ...
- 格式化你的git message
https://github.com/angular/angular.js/blob/f3377da6a748007c11fde090890ee58fae4cefa5/CONTRIBUTING.md# ...