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# ...

VB 获取所有窗体菜单信息

VB 获取所有窗体菜单信息的更多相关文章

随机推荐

热门专题