clsfile.cls

利用Visual Basic6.0制作的字符串搜索处理系统!推荐中

    End If
    
    If InStr(pstrData, " Lib ") > 0 Then
        ' get the library
        strLib = Mid$(pstrData, InStr(InStr(pstrData, " Lib "), pstrData, Chr$(34)) + 1, _
            InStr(InStr(InStr(pstrData, " Lib "), pstrData, Chr$(34)) + 1, pstrData, Chr$(34)) - _
            InStr(InStr(pstrData, " Lib "), pstrData, Chr$(34)) - 1)
        ' remove the library from the working string
        pstrData = Left$(pstrData, InStr(pstrData, " Lib ") - 1) & _
            Mid$(pstrData, InStr(InStr(InStr(pstrData, " Lib "), pstrData, Chr$(34)) + 1, pstrData, Chr$(34)) + 1)
    End If
    
    If InStr(pstrData, " Alias ") > 0 Then
        ' get the alias
        strAlias = Mid$(pstrData, InStr(InStr(pstrData, " Alias "), pstrData, Chr$(34)) + 1, _
            InStr(InStr(InStr(pstrData, " Alias "), pstrData, Chr$(34)) + 1, pstrData, Chr$(34)) - _
            InStr(InStr(pstrData, " Alias "), pstrData, Chr$(34)) - 1)
        ' remove the alias from the working string
        pstrData = Left$(pstrData, InStr(pstrData, " Alias ") - 1) & _
            Mid$(pstrData, InStr(InStr(InStr(pstrData, " Alias "), pstrData, Chr$(34)) + 1, pstrData, Chr$(34)) + 1)
    End If
    
    intPos1 = InStr(pstrData, "(") + 1
    intPos2 = InStrRev(pstrData, ")")
    ' look for array as return value and adjust position
    If Right$(pstrData, 2) = "()" Then
        If InStrRev(pstrData, ")", Len(pstrData) - 2) >= intPos1 Then
            intPos2 = InStrRev(pstrData, ")", Len(pstrData) - 2)
        End If
    End If
    ' if we didn't find an opening bracket, this isn't a sub/function/property, so exit.
    If intPos1 = 1 Then Exit Function
    ' if we didn't find an closing bracket, this isn't a sub/function/property, so exit.
    If intPos2 = 0 Then Exit Function
    
    astrWhole = Split(Mid$(pstrData, intPos1, intPos2 - intPos1), ",")
    For i = 0 To UBound(astrWhole)
        astrWhole(i) = Trim$(astrWhole(i))
    Next i
    If InStr(pstrData, "property ") > 0 Then
        If InStr(pstrData, " set ") > 0 Then strExtra = "[Set]"
        If InStr(pstrData, " let ") > 0 Then strExtra = "[Let]"
        If InStr(pstrData, " get ") > 0 Then strExtra = "[Get]"
    End If
    
    ' work out the scope
    If InStr(pstrData, "private") > 0 Then
        strExtra = strExtra & " - Private"
    ElseIf InStr(pstrData, "friend") > 0 Then
        strExtra = strExtra & " - Friend"
    Else
        strExtra = strExtra & " - Public"
    End If
    
    ' work out the return data type
    If InStr(pstrData, "Function ") > 0 Or InStr(pstrData, "property get ") > 0 Then
        intStart = -1
        If Right$(pstrData, 2) = "()" Then intStart = Len(pstrData) - 2
        If InStrRev(pstrData, ")", intStart) = Len(Trim$(pstrData)) Then
            strExtra = LTrim$(strExtra & " ") & "(返回数据类型: Variant)"
        Else
            strExtra = LTrim$(strExtra & " ") & "(返回数据类型: " & Mid$(pstrData, InStrRev(pstrData, " ") + 1) & ")"
        End If
    End If
    
    ' add in the API items, if found
    If Trim$(strLib) <> "" Or Trim$(strAlias) <> "" Then
        pstrData = Replace(pstrData, " (", "(")
        strExtra = strExtra & IIf(Trim$(strLib) <> "", " Lib: " & strLib, "") & _
            IIf(Trim$(strAlias) <> "", " Alias: " & strAlias, "")
    End If
    
    strOutput = strOutput & "<ul><b>" & GetItemName(pstrData) & IIf(strExtra = "", "", "  " & strExtra) & "</b><br>" & vbCrLf
    
    If Trim$(pstrDescr) <> "" Then
        strOutput = strOutput & "<ul>" & pstrDescr & "</ul><p>" & vbCrLf
    End If
    
    If UBound(astrWhole) = -1 Then
        ' no parameters for function
        strOutput = strOutput & "<ul><em>没有参数</em>" & vbCrLf
    
    Else
        ' function has paramters
        strOutput = strOutput & "<ul><table class=""GENERAL""><tr><td class=""HEADERBAND"">可选</td>" & _
            "<td class=""HEADERBAND"">ByVal/ByRef</td><td class=""HEADERBAND"">变量</td>" & _
            "<td class=""HEADERBAND"">数据类型</td></tr>" & vbCrLf
        
        For i = 0 To UBound(astrWhole)
            
            ' process any default value
            ' put brackets around the value
            If InStr(astrWhole(i), " = ") > 0 Then
                astrWhole(i) = Replace(astrWhole(i), " = ", "(") & ")"
            End If
            
            astrParts = SpecialSplit(Trim(astrWhole(i)), " ")
            If UBound(astrParts) >= 0 Then
                intCount = 0
                strType = ""
                strOutput = strOutput & "<tr>" & vbCrLf
                If astrParts(intCount) = "Optional" Then
                    strOutput = strOutput & "<td class=""CELL"">可选</td>" & vbCrLf
                    intCount = intCount + 1
                Else
                    strOutput = strOutput & "<td></td>" & vbCrLf
                End If
                If astrParts(intCount) = "ByVal" Or astrParts(intCount) = "ByRef" Then
                    strOutput = strOutput & "<td class=""CELL"">" & astrParts(intCount) & "</td>" & vbCrLf
                    If UBound(astrParts) > intCount Then intCount = intCount + 1
                Else
                    strOutput = strOutput & "<td></td>" & vbCrLf
                End If
                If astrParts(intCount) = "As" Then
                    intCount = intCount + 1
                Else
                    Select Case Right$(Trim$(astrParts(intCount)), 1)
                        Case "!": strType = "(Single)"
                        Case "#": strType = "(Double)"
                        Case "%": strType = "(Integer)"
                        Case "&": strType = "(Long)"
                        Case "$": strType = "(String)"
                        Case "@": strType = "(Currency)"
                    End Select
                End If
                strOutput = strOutput & "<td class=""CELL"">" & astrParts(intCount) & "</td>" & vbCrLf
                If UBound(astrParts) > intCount Then
                    intCount = intCount + 1
                    If astrParts(intCount) = "As" Then intCount = intCount + 1
                    strOutput = strOutput & "<td class=""CELL"">" & astrParts(intCount) & "</td>" & vbCrLf
                End If
                If strType <> "" Then
                    strOutput = strOutput & "<td class=""CELL"">" & strType & "</td>" & vbCrLf
                End If
                strOutput = strOutput & "</tr>" & vbCrLf
            End If
        Next i
    
        strOutput = strOutput & "</table>" & vbCrLf
    End If

    ' process any attributes for this procedure
    If Trim$(pstrAttrib) <> "" And mblnIncludeAttributes = True Then
        strOutput = strOutput & "<br><br><b>程序属性</b><br>" & vbCrLf
        strOutput = strOutput & "<table class=""GENERAL""><tr><td class=""HEADERBAND"">属性</td>" & _
            "<td class=""HEADERBAND"">值</td></tr>" & vbCrLf
        
        strAttrib = Split(pstrAttrib, "~")
        For i = 0 To UBound(strAttrib)
            strOutput = strOutput & "<tr><td class=""CELL"">" & Split(strAttrib(i), "|")(0) & "</td>" & _
                "<td class=""CELL"">" & Split(strAttrib(i), "|")(1) & "</td></tr>" & vbCrLf
        Next i
        strOutput = strOutput & "</table>" & vbCrLf
    End If
    
    strOutput = strOutput & "</ul></ul>" & vbCrLf
End If

ParseParamsHTML = strOutput

End Function

Private Function ProcessAttributes(ByVal pstrData As String) As String

Dim strReturn As String
Dim strValue As String
Dim strSplit() As String

strValue = Trim$(AfterEqual(pstrData))

If InStr(pstrData, ".VB_Description") > 0 Then
    strReturn = "Description|" & strValue
End If

If InStr(pstrData, ".VB_HelpID") > 0 Then
    strReturn = "Help Context ID|" & strValue
End If

If InStr(pstrData, ".VB_MemberFlags") > 0 Then
    strReturn = ProcessMemberFlags(CLng("&H" & strValue))
End If

If InStr(pstrData, ".VB_UserMemID") > 0 Then
    strReturn = ProcessProcedureID(CLng(strValue))
End If

If InStr(pstrData, ".VB_ProcData.VB_Invoke_Property") > 0 Then
    strSplit = Split(strValue, ";")
    If UBound(strSplit) > 0 Then
        strReturn = "Property Browser Page|" & strSplit(0) & "," & _
            "Property Category|" & strSplit(1)
    Else
        strReturn = "Property Browser Page|" & strSplit(0)
    End If
End If

ProcessAttributes = strReturn

End Function

Public Function ProcessMemberFlags(ByVal plngData As Long) As String

Dim strReturn As String
Dim blnMemberFlags(7) As Boolean

If plngData >= VBMemberFlags.UpdateImmediate Then
    blnMemberFlags(7) = True
    plngData = plngData - VBMemberFlags.UpdateImmediate
End If
If plngData >= VBMemberFlags.DontShowInPropertyBrowser Then
    blnMemberFlags(6) = True
    plngData = plngData - VBMemberFlags.DontShowInPropertyBrowser
End If
If plngData >= VBMemberFlags.UserInterfaceDefault Then
    blnMemberFlags(5) = True
    plngData = plngData - VBMemberFlags.UserInterfaceDefault
End If
If plngData >= VBMemberFlags.HideThisMember Then
    blnMemberFlags(4) = True
    plngData = plngData - VBMemberFlags.HideThisMember
End If
If plngData >= VBMemberFlags.BindsToDataField Then
    blnMemberFlags(3) = True
    plngData = plngData - VBMemberFlags.BindsToDataField
End If
If plngData >= VBMemberFlags.ShowInDataBindingsCollection Then
    blnMemberFlags(2) = True
    plngData = plngData - VBMemberFlags.ShowInDataBindingsCollection
End If
If plngData >= VBMemberFlags.PropertyCallsCanPropertyChange Then
    blnMemberFlags(1) = True
    plngData = plngData - VBMemberFlags.PropertyCallsCanPropertyChange
End If
If plngData >= VBMemberFlags.DataBound Then
    blnMemberFlags(0) = True
    plngData = plngData - VBMemberFlags.DataBound
End If

If blnMemberFlags(4) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Attributes|Hide this member"
End If
If blnMemberFlags(5) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Attributes|User Interface Default"
End If
If blnMemberFlags(6) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Attributes|Don't show in property browser"
End If
If blnMemberFlags(0) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Data binding|Data bound"
End If
If blnMemberFlags(3) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Data binding|Property binds to data field"
End If
If blnMemberFlags(2) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Data binding|Show in DataBindings collection at run time"
End If
If blnMemberFlags(1) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Data binding|Property will call CanPropertyChange before changing"
End If
If blnMemberFlags(7) = True Then
    strReturn = strReturn & IIf(strReturn = "", "", ",") & "Data binding|Update Immediate"
End If
    
ProcessMemberFlags = strReturn

End Function

Private Function ProcessProcedureID(ByVal plngData As Long) As String

Dim strReturn As String

Select Case plngData
    Case 0: strReturn = "Default"
    Case -520: strReturn = "Appearance"
    Case -500: strReturn = "Autosize"
    Case -501: strReturn = "BackColor"
    Case -502: strReturn = "BackStyle"
    Case -503: strReturn = "BorderColor"
    Case -504: strReturn = "BorderStyle"
    Case -505: strReturn = "BorderWidth"
    Case -518: strReturn = "Caption"
    Case -507: strReturn = "DrawMode"
    Case -508: strReturn = "DrawStyle"
    Case -509: strReturn = "DrawWidth"
    Case -514: strReturn = "Enabled"
    Case -510: strReturn = "FillColor"
    Case -511: strReturn = "FillStyle"
    Case -512: strReturn = "Font"
    Case -513: strReturn = "ForeColor"
    Case -515: strReturn = "hWnd"
    Case -516: strReturn = "TabStop"
    Case -517: strReturn = "Text"
    Case -611: strReturn = "RightToLeft"
End Select

If strReturn <> "" Then ProcessProcedureID = "Procedure ID|" & strReturn

End Function

Public Sub SaveHTML(ByVal pstrPath As String)

Dim intFileNum As Integer

intFileNum = FreeFile

Open pstrPath & IIf(Right$(pstrPath, 1) = "\", "", "\") & FileOnly(ExtractFile(mstrFile, "")) & ".html" For Output As #intFileNum

Print #intFileNum, AddHTMLHeader
Print #intFileNum, AddHTMLBody
Print #intFileNum, AddHTMLFooter

Close #intFileNum

End Sub