2024年1月6日发(作者：)

VB获取所有窗体菜单信息VERSION 5.00Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; ""Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; ""Begin 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 x Text1

Height = 1095 Left = 600 MultiLine = -1 'True TabIndex = 4 Top = 720 Width = 5535 End Begin ew 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 Dialog CommonDialog1

Left = 3480 Top = 5520 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin dButton Command2

BackColor = &H00C0C0C0& Caption = "All" Height = 615 Left = 8040 Style = 1 'Graphical TabIndex = 1 Top = 5640 Width = 1935 End Begin dButton Command1

BackColor = &H00C0C0C0& Caption = "get menus from file(*.frm)" Height = 735 Left = 5040 Style = 1 'Graphical TabIndex = 0 Top = 5640 Width = 2175 End Begin 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 EndEndAttribute VB_Name = "Form1"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute VB_Exposed = FalseOption ExplicitConst sFolder = "D:projectVB6Test"Dim str As StringDim strAll As StringPrivate Sub Command1_Click() On Error GoTo 1 Dim sCaption As String sCaption = "" str = "" Dim i As Integer Dim pos As Integer Dim count As Integer Dim spacelen As Integer Dim freenum As Integer freenum = le 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 ", vbTextCompare) ' If pos > 0 Then count = count + 1 spacelen = ((pos - 1) 3 - 1) * 4 , "name" & count, Space(spacelen) & Trim(Right(str, Len(str) - pos - 12)) (count). , "caption" & count, "" (count). , "index" & count, "" (count). , "Checked" & count, "False" (count). , "Enabled" & count, "True" (count). , "Visible" & count, "True" End If pos = InStr(1, str, "Caption", vbTextCompare) ' If pos > 0 Then If count > 0 Then (count).ListSubItems("caption" & count).Text = Space(spacelen) & Replace(Trim(Right(str, Len(str) - pos - 16)), """", "") sCaption = (count).ListSubItems("caption" & count).Text sCaption = Replace(sCaption, "&", "") If Trim(sCaption) <> "-" Then = 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 (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 (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 (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 (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 '(count).ListSubItems("caption" & count).Text = "" End If End If End IflbEnd: If InStr(1, str, "Attribute VB_Name", vbTextCompare) > 0 Then Exit Do End If Loop Close freenum End With Exit Sub1:End SubPrivate 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 Dim i As Integer Dim pos As Integer Dim count As Integer Dim spacelen As Integer Dim freenum As Integer freenum = le Open sFileName For Input As freenum Do While Not EOF(freenum) i = i + 1 Line Input #freenum, str pos = InStr(1, str, "Begin ", vbTextCompare) ' If pos > 0 Then count = count + 1 spacelen = ((pos - 1) 3 - 1) * 4 , "name" & count, Space(spacelen) & Trim(Right(str, Len(str) - pos - 12)) (count). , "caption" & count, "" (count). , "index" & count, "" (count). , "Checked" & count, "False" (count). , "Enabled" & count, "True" (count). , "Visible" & count, "True" End If pos = InStr(1, str, "Caption", vbTextCompare) ' If pos > 0 Then If count > 0 Then ' (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 & 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 (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 (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 (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 (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 '(count).ListSubItems("caption" & count).Text = "" End If End If End IflbEnd: 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 Sub1:MsgBox ptionEnd SubPrivate Sub Command2_Click()Dim cnt As Integer, i As IntegerDim fso As ObjectDim folder As ObjectDim subfolder As ObjectDim file As ObjectSet fso = CreateObject("stemobject")Set folder = der(sFolder) ' get all files in folderFor Each file In If (Right(file, 4) = ".frm") Then cnt = cnt + 1 End IfNextFor Each file In If (Right(file, 4) = ".frm") Then 'MsgBox file getMenu (file) i = i + 1 Caption = file & " done." & i & "/" & cnt End IfNextSet file = TextFile("c:", True) et fso = NothingSet folder = = strAllEnd Sub

Private Sub Form_Load() With ListView1 .View = lvwReport . , "name", "name" . , "caption", "caption" . , "index", "index" . , "Checked", "Checked" . , "Enabled", "Enabled" . , "Visible", "Visible" End With SaveSetting "VBMenus", "path", "filename", & "" & eEnd Sub'*************************************************************************'*************************************************************************Private Sub toword(ByVal rowcount As Integer, ByVal fieldscount As Integer) On Error Resume Next If rowcount > 0 Then Dim wdapp As ation Dim wddoc As nt Dim atable As Dim i As Integer, j As Integer Set wdapp = New ation Set wddoc = With wdapp .Visible = True .Activate Set atable = .(., rowcount + 1, fieldscount) For i = 1 To fieldscount (1, i).After Headers(i) Next i For i = 1 To rowcount (i + 1, 1).After ems(i).Text (i + 1, 2).After ems(i).ListSubItems(1).Text (i + 1, 3).After ems(i).ListSubItems(2).Text (i + 1, 4).After ems(i).ListSubItems(3).Text (i + 1, 5).After ems(i).ListSubItems(4).Text (i + 1, 6).After ems(i).ListSubItems(5).Text Next i End With '??word?? Set atable = Nothing Set wdapp = Nothing Set wddoc = Nothing Else MsgBox "err", vbCritical End IfEnd Sub