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万条,每月保持两次以上规模数据更新,合作伙伴包括:百度 ...
随机推荐
- [零基础学python]啰嗦的除法
除法啰嗦的,不仅是python. 整数除以整数 看官请在启动idle之后.练习以下的运算: >>> 2/5 0 >>> 2.0/5 0.4 >>> ...
- Maven快速安装配置
环境:windows7_x86 maven3.3.3 maven是管理项目的常用工具,不用安装,直接配置即可.在配置maven前,需要先安装JDK. 1,安装JDK(注意此版本的Maven要 ...
- WPF拖拽文件(拖入拖出)，监控拖拽到哪个位置，类似百度网盘拖拽
1.往wpf中拖文件 // xaml <Grid x:Name="grid_11" DragOver="Grid_11_DragOver" Drop=&q ...
- jQuery之链式编程
使用的思想:隐式迭代. <button>快速</button> <button>快速</button> <button>快速</but ...
- 简单的python笔试题
1.输出九九乘法口诀 for i in range(1,10): for j in range(1,i+1): print('{}*{}={}'.format(j,i,i*j),end=' ') pr ...
- 04-A的LU分解
一.矩阵$AB$的逆 $(AB)^{-1}=B^{-1}A^{-1}$,顺序正好相反 二.$A=LU$ 如矩阵: $\left[\begin{array}{ll}{2} & {1} \\ {8 ...
- Python实现IP地址归属地查询
一.使用淘宝IP地址库查询 使用淘宝的Rest API,可以快速查询IP地址的归属地: 图00-淘宝IP地址库RestAPI使用说明 图01-使用淘宝免费IP地址库-查询IP归属地 存在问题:淘宝的免 ...
- 分岔 Bifurcations
1. saddle-node bifurcation 2. transcritical bifurcation 3.pitchfork bifurcation 4. Hopf bifurcation ...
- u-boot-2016.09 make编译过程分析（二）
版权声明:本文为博主原创文章,遵循 CC 4.0 BY-SA 版权协议,转载请附上原文出处链接和本声明.本文链接:https://blog.csdn.net/guyongqiangx/article/ ...
- noip级别模板小复习
不是很noip的知识点就不写了. dij什么的太easy就不写了. 缩点 注意\(Tarjan\)在缩边双和求强联通分量时候的区别. 一个要判断是否在栈内一个不要. 最后\(topsort\)来\(d ...