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万条,每月保持两次以上规模数据更新,合作伙伴包括:百度 ...

随机推荐

【LGR-065】洛谷11月月赛 III Div.2
临近$CSP$...... 下午打了一发月赛,感觉很爽. 非常菜的我只做了前两题......然而听说前两题人均过...... 写法不优秀被卡到$#1067$...... T1:基础字符串练习题: 前缀 ...
Cleaning Robot （bfs+dfs）
Cleaning Robot (bfs+dfs) Here, we want to solve path planning for a mobile robot cleaning a rectangu ...
[零基础学python]啰嗦的除法
除法啰嗦的,不仅是python. 整数除以整数看官请在启动idle之后.练习以下的运算: >>> 2/5 0 >>> 2.0/5 0.4 >>> ...
how to install protobuff python
当前环境: operate system: Ubuntu 14.04.1 LTS protoc --version: libprotoc 2.5.0 protocol-buffers versi ...
React -- 3/100 】组件通讯
通讯 | props | prop-types 组件通讯 Props: 组件无论是使用函数声明还是通过 class 声明,都决不能修改自身的 props /* class */ .parent-box ...
C#批量将数据插入SQLServer数据库
Database db = CreateDatabase(); var varConnnection = db.CreateConnection(); //获取连 ...
Linux 设置定时清除buff/cache的脚本
Linux 设置定时清除buff/cache的脚本查看内存缓存状态 [root@heyong ~]# free -m total used free shared buff/cache availa ...
linux 防止误操作 mysql 数据库技巧
mysql 帮助说明 1[oldboy_c64 ~]# mysql --help|grep dummy 2 -U, --i-am-a-dummy Synonym for option --safe-u ...
<mvc:argument-resolvers> 自定义注解处理参数
直接看引自: http://blog.csdn.net/u013160932/article/details/50609092
合肥学院ACM集训队第一届暑假友谊赛 B FYZ的求婚之旅 D 计算机科学家 F 智慧码题解
比赛网址:https://ac.nowcoder.com/acm/contest/994#question B FYZ的求婚之旅思路: 然后用快速幂即可. 细节见代码: #include <i ...

VB 获取所有窗体菜单信息

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

随机推荐

热门专题