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万条,每月保持两次以上规模数据更新,合作伙伴包括:百度 ...
随机推荐
- JetBrains下载历史版本
https://www.jetbrains.com/clion/download/other.html 在上方的链接中将clion改为idea,phpstrom.webstrom等等
- C++编译器对属性的初始化检查远没有Java严格
C++编译器对属性的初始化检查远没有Java严格// Java编译通过:class yy { public static void main(String[] args) { int i; Syste ...
- liunx驱动----信号量的实现
使用信号量必须包含 <asm/semaphore.h> 头文件.其中相关结构体 struct semaphore 可以通过以下几种方式来声明或者初始化. 1.void sema_in ...
- 【源码解读】cycleGAN（二) ：训练
源码地址:https://github.com/aitorzip/PyTorch-CycleGAN 训练的代码见于train.py,首先定义好网络,两个生成器A2B, B2A和两个判别器A, B,以及 ...
- luogu P1399 [NOI2013]快餐店
传送门 注意到答案为这个基环树直径\(/2\) 因为是基环树,所以考虑把环拎出来.如果直径不过环上的边,那么可以在环上每个点下挂的子树内\(dfs\)求得.然后如果过环上的边,那么环上的部分也是一条链 ...
- linux中的文件类型以及查看文件类型的方法
Linux文件类型和文件的文件名所代表的意义是两个不同的概念,在linux中文件类型与文件扩展名没有关系.它不像Windows那样是依靠文件后缀名来区分文件类型的,在linux中文件名只是为了方便操作 ...
- DOMContentLoaded和load的区别
一.概念 DOMContentLoaded 当初始的 HTML 文档被完全加载和解析完成之后,DOMContentLoaded 事件被触发,而无需等待样式表.图像和子框架的完成加载. load loa ...
- Mybatis驼峰式命名
<?xml version="1.0" encoding="UTF-8" ?> <!DOCTYPE configuration PUBLIC ...
- mplayer - Linux下的电影播放器
概要 mplayer [选项] [ 文件 | URL | 播放列表 | - ] mplayer [全局选项] 文件1 [特定选项] [文件2] [特定选项] mplayer [全局选项] {一组文件和 ...
- [转]tKC(The Keyboard Caper)的自传
每个玩儿计算机的朋友都知道破解,或多或少地使用着各种各样的破解,也就逐渐地知道了一些著名的破解团体和破解人,比如:PC(Phrozen Crew).CiA(Crackers in Action)COR ...