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