• 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:projectVB6Test"
    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 workingHytekSWMM7", "") & 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
    

      

  • 相关阅读:
    python数据类型详解
    python代码风格指南:pep8 中文翻译
    尝试一下: 仅加密已用磁盘空间
    Anaconda多环境多版本python配置指导
    Python科学计算(一)环境简介——Anaconda Python
    Python Collections里一些常用字典类的用法
    旋转链表
    Java 利用 split 方法切割字符串
    Java 语言设计中的部分共享策略
    JumpGame I
  • 原文地址:https://www.cnblogs.com/wgscd/p/10832863.html
Copyright © 2020-2023  润新知