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 获取所有窗体菜单信息的更多相关文章

  1. asp.net C#获取程序文件相关信息

    代码如下 复制代码 using System.Reflection;using System.Runtime.CompilerServices; //// 有关程序集的常规信息是通过下列// 属性集控 ...

  2. C++通过WIN32 API获取逻辑磁盘详细信息

      众所周知,在微软的操作系统下编写应用程序,最主要的还是通过windows所提供的api函数来实现各种操作的,这些函数通常是可以直接使用的,只要包含windows.h这个头文件. 今天我们主要介绍的 ...

  3. 获取Winform窗体、工作区 宽度、高度、命名空间、菜单栏高度等收集

    MessageBox.Show("当前窗体标题栏高"+(this.Height - this.ClientRectangle.Height).ToString());//当前窗体标 ...

  4. php递归获取无限分类菜单

    从数据库获取所有菜单信息,需要根据id,pid字段获取主菜单及其子菜单,以及子菜单下的子菜单,可以通过函数递归来实现. <?php class Menu { public $menu = arr ...

  5. MFC获取各个窗体(体)之间的指针(对象)

    MFC在非常多的对话框操作中,我们常常要用到在一个对话框中调用还有一个对话框的函数或变量.能够用例如以下方法来解决.    HWND hWnd=::FindWindow(NULL,_T("S ...

  6. Dynamics 365客户端编程示例:获取当前用户的信息,表单级通知/提示,表单OnLoad事件执行代码

    我是微软Dynamics 365 & Power Platform方面的工程师罗勇,也是2015年7月到2018年6月连续三年Dynamics CRM/Business Solutions方面 ...

  7. Qt网络获取本机网络信息

    下面我们就讲解如何获取自己电脑的IP地址以及其他网络信息.这一节中,我们会涉及到网络模块(QtNetwork Module)中的QHostInfo ,QHostAddress ,QNetworkInt ...

  8. 使用PHP获取图像文件的EXIF信息

    在我们拍的照片以及各类图像文件中,其实还保存着一些信息是无法直观看到的,比如手机拍照时会有的位置信息,图片的类型.大小等,这些信息就称为 EXIF 信息.一般 JPG . TIFF 这类的图片文件都会 ...

  9. 调用手机在线API获取手机号码归属地信息

    手机在线(www.showji.com)始创于2001年,发展至今已拥有国内最准确.号段容量最大的手机号码归属地数据库系统, 目前号段容量将近33万条,每月保持两次以上规模数据更新,合作伙伴包括:百度 ...

随机推荐

  1. Django、Flask、Tornado的区别?

    Django:Python 界最全能的 web 开发框架,battery-include 各种功能完备,可维护性和开发速度一级棒.常有人说 Django 慢,其实主要慢在 Django ORM 与数据 ...

  2. 阿里云服务器重启出现An error occurred 如何处理

    最近网站重启阿里云服务后,出现 An error occurred, An error occurred. Sorry, the page you are looking for is current ...

  3. angularJS(一):表达式、指令

    简介 以 JavaScript 编写的库,是一个 JavaScript 框架 一.表达式 AngularJS 使用 表达式 把数据绑定到 HTML. 表达式写在双大括号内:{{ expression ...

  4. Kibana 基本操作

    es中的索引对应mysql的数据库.类型对应mysql的表.文档对应mysql的记录.映射对应mysql的索引索引:index类型:type映射:mappings 1.创建索引在kibana的Dev ...

  5. linux 深入应用 NFS

    以下实验大家用主机名来区分服务器端和客户端, 服务器端为 NFS_Server ip-192.168.1.4: 客户端为 NFS_Client ip-192.168.1.5: 实例一 将/tmp 分享 ...

  6. ubuntu上的疑难杂症(不定期更新……)

    ubuntu系统英伟达显卡驱动怎么装 sudo apt-get purge nvidia* #如果之前安装过显卡驱动,就执行这一句来卸载 sudo apt-add-repository ppa:gra ...

  7. CentOS7 安装 Mysql5.6.40

    CentOS7.5二进制安装MySQL-5.6.40 安装之后登陆不上,mysql.user 表是空的时: Mysql User表为空 mysql创建用户报错ERROR 1364 (HY000): F ...

  8. Java并发——原子变量和原子操作

    很多情况下我们只是需要一个简单的.高效的.线程安全的递增递减方案.注意,这里有三个条件:简单,意味着程序员尽可能少的操作底层或者实现起来要比较容易:高效意味着耗用资源要少,程序处理速度要快:线程安全也 ...

  9. GUI学习之二十五——QFontDialog学习总结

    今天学习字体对话框——QFontDialog()控件. QFontDialog()是继承自QDialog()的一个子类,用来选择给定的字体(包括字体.字号.样式等) 一.构造函数 QFontDialo ...

  10. 格式化你的git message

    https://github.com/angular/angular.js/blob/f3377da6a748007c11fde090890ee58fae4cefa5/CONTRIBUTING.md# ...