Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/desaware/apitools/listapi.bas

BASIC Source File | 1997-02-13 | 16.4 KB | 450 lines

Attribute VB_Name = "modListAPI"
' Copyright ⌐ 1996 by Desaware Inc.
' Part of the Desaware API Toolkit
' All Rights Reserved

Option Explicit
Public NL As String
Public lstHwnd&


' constants for the cmbType combo box
Public Const CMB_DECLARES = 0
Public Const CMB_TYPES = 1
Public Const CMB_CONSTANTS = 2
Public which%  'Variable that holds one of the above constants

' Which API set should I copy?
Public Const OPT_WIN16 = 0
Public Const OPT_WIN32 = 1
Public Const OPT_BOTH = 2

'Variables containing options
Public options% 'OPT_WIN16, OPT_WIN32, or OPT_BOTH
Public Comments% ' Should I insert comments?
Public Glbl% ' Should I put "public" in front of constants?
Public Searching%

'Addin stuff
Public IsAddin%
Public objVBInst As Object
Public AlreadyCopied% 'Were the selected items already copied to the clipboard?
                      ' Used in the mnuFileExit  procedure

Public DeclaresSelected() As DefInfo  'Structures that contain the selected elements
Public TypesSelected() As DefInfo     'These are used to fill the lstSelected list box.
Public ConstantsSelected() As DefInfo

' Number of entries in the corresponding FOOBARselected() array
Public TypesNo&
Public DeclaresNo&
Public ConstantsNo&

' Structure datatype.
Public Type DefInfo
    Free As Integer 'Whether this entry has been freed by a removal
    DefName As String ' The name of the type/constant/function
End Type


'Constants/functions used to find strings in the lstSelected listbox
Public Const LB_FINDSTRINGEXACT = &H1A2
Public Const WM_KEYDOWN& = &H100&
Public Const WM_KEYUP& = &H101&
Public Const WM_CHAR& = &H102&


Public Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, lParam As Any)
Public Declare Function OSWritePrivateProfileString% Lib "Kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal FileName$)
Public Declare Function SendMessageByString& Lib "user32" Alias "SendMessageA" (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, ByVal lParam$)
Public Declare Function GetFocus& Lib "user32" ()

Sub Main()
   frmAPI.Show
End Sub

' Adds an item from the string to the
' lstSelected listbox. Adds the new entry to the
' array.
' This function is called from cmdQuery_Click
Public Sub QueryAddItem(myArray() As DefInfo, myCount&, myName$)
    Dim WhichFree& ' The index of the first free element in the array.
    Dim i&

    ' If there is aready that string in the lstSelected list box, return an error.
    If SendMessageByString&(frmAPI.lstSelected.hwnd, LB_FINDSTRINGEXACT, 0, _
                myName$) >= 0 Then
'        Beep
'        MsgBox myName$ & ": That entry is already selected.", 48, "API Copier"
        Exit Sub
    End If

    WhichFree& = -1 ' Nothing yet.

    For i& = 0 To myCount& - 1
        If myArray(i&).Free = True Then ' If it's free then...
            WhichFree& = i& ' We found it!
            Exit For
        End If
    Next i&

    If WhichFree& = -1 Then  ' If we didn't find any extra holes,
        ReDim Preserve myArray(myCount&) ' We add one more element to the end of the array.
        WhichFree& = myCount& ' The last one is the free element
        myCount& = myCount& + 1 ' Increment count
    End If

    myArray(WhichFree&).Free = False ' It's not free anymore
    myArray(WhichFree&).DefName = myName$ 'Set the name field of the structure
    frmAPI.lstSelected.AddItem myArray(WhichFree&).DefName ' Add it to the listbox
    frmAPI.lstSelected.ItemData(frmAPI.lstSelected.NewIndex) = _
                    WhichFree& ' Link the element number to the listbox item.
End Sub
' Adds an item from the current record of the database to the
' lstSelected listbox. Adds the new entry to the
' array.
' This function is called from cmdAdd_click
Public Sub AAddItem(myArray() As DefInfo, myCount&)
    UpdateBoundField ' Make sure dataAPI2 is up to date - 4/14/96 DSA

    ' If there is aready that string in the lstSelected list box, return an error.
    If SendMessageByString&(frmAPI.lstSelected.hwnd, LB_FINDSTRINGEXACT, 0, _
                CStr(frmAPI.dataAPI2.Recordset("NAME").Value)) >= 0 Then
        Beep
        MsgBox "That entry is already selected.", 48, "API Copier"
        Exit Sub
    End If
    AlreadyCopied% = False
    Dim WhichFree& ' The index of the first free element in the array.
    Dim i&
    WhichFree& = -1 ' Nothing yet.

    For i& = 0 To myCount& - 1
        If myArray(i&).Free = True Then ' If it's free then...
            WhichFree& = i& ' We found it!
            Exit For
        End If
    Next i&

    If WhichFree& = -1 Then  ' If we didn't find any extra holes,
        ReDim Preserve myArray(myCount&) ' We add one more element to the end of the array.
        WhichFree& = myCount& ' The last one is the free element
        myCount& = myCount& + 1 ' Increment count
    End If

    myArray(WhichFree&).Free = False ' It's not free anymore
    myArray(WhichFree&).DefName = CStr(frmAPI.dataAPI2.Recordset("Name").Value) 'Set the name field
                                                                         'Of the structure
    frmAPI.lstSelected.AddItem myArray(WhichFree&).DefName ' Add it to the listbox
    frmAPI.lstSelected.ItemData(frmAPI.lstSelected.NewIndex) = WhichFree& ' Link the element number
                                                            ' To the listbox item.
End Sub




' Remove an item from the lstSelected listbox and the array
Public Sub ARemoveItem(myArray() As DefInfo, myCount&, Index&)
    Dim ArrayIndex&, i&
    ArrayIndex& = frmAPI.lstSelected.ItemData(Index&)
    myArray(ArrayIndex&).Free = True ' Free it.
    frmAPI.lstSelected.RemoveItem Index&
    AlreadyCopied% = False
End Sub


Public Function CopyConstants%(tableName$, clipstring$)
    Dim tblConsts As Object, i&, smthCopied%
'**************************************
'* WINDOWS CONSTANTS
    DoEvents
    Set tblConsts = frmAPI.dataAPI.Database.OpenTable(tableName$ + " Constants")
    tblConsts.Index = "NAME"

    For i& = 0 To ConstantsNo& - 1 'Loop for every constant without the "Free" flag.
        frmAPI.pctStatus.Line (0, 0)-(i& / 3 / ConstantsNo& * frmAPI.pctStatus.Width + frmAPI.pctStatus.Width / 3, frmAPI.pctStatus.Height), QBColor(9), BF
        If ConstantsSelected(i&).Free = False Then
            smthCopied = True
            tblConsts.Seek "=", ConstantsSelected(i&).DefName
            If tblConsts.NoMatch Then ' Add appropriate comment IF neccessary
                If Comments% Then
                    clipstring$ = clipstring$ & "'Const " & ConstantsSelected(i&).DefName & " is not available "
                    clipstring$ = clipstring$ & "in the " & tableName$ & " API." & NL
                End If
            Else

                'Check the options: If Glbl%, then add "PUBLIC" to constant definition.
                If Glbl% = True Then
                    clipstring$ = clipstring$ & "Public "
                Else
                    clipstring$ = clipstring$ & "Private "
                End If

                clipstring$ = clipstring$ & "Const "
                clipstring$ = clipstring$ & tblConsts("NAME")

                Select Case tblConsts("TYPE")
                    Case 0: 'Variant
                    Case 1: 'Integer
                        clipstring$ = clipstring$ & "%"
                    Case 2: 'Long
                        clipstring$ = clipstring$ & "&"
                    Case 3: 'single
                        clipstring$ = clipstring$ & "!"
                    Case 4: 'double
                        clipstring$ = clipstring$ & "#"
                    Case 5: 'currency
                        clipstring$ = clipstring$ & "@"
                    Case 6: 'string
                        clipstring$ = clipstring$ & "$"
                End Select
                'Extract the value from the table and paste it onto the end.
                clipstring$ = clipstring$ & " = " & tblConsts("VALUE") & NL
            End If 'Nomatch
            End If ' IsFree
       Next i&
    CopyConstants% = smthCopied%
End Function

Public Function CopyFunctions%(tableName$, clipstring$)
    Dim tblFuncs As Object, i&, smthCopied%
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''' WINDOWS FUNCTIONS
    frmAPI.Status = "Copying & " & tableName$ & " Functions..."
    DoEvents
    Set tblFuncs = frmAPI.dataAPI.Database.OpenTable(tableName$ + " Functions")
    tblFuncs.Index = "NAME"
    For i& = 0 To DeclaresNo& - 1
        If DeclaresSelected(i&).Free = False Then
            smthCopied = True
            tblFuncs.Seek "=", DeclaresSelected(i&).DefName
            If tblFuncs.NoMatch Then
                If Comments% Then
                    clipstring$ = clipstring$ & "'Function " & DeclaresSelected(i&).DefName & " is not available "
                    clipstring$ = clipstring$ & "in the " & tableName$ & " API." & NL
                End If
            Else
                ' Do either private or public
                If Glbl% = True Then
                    clipstring$ = clipstring$ & "Public "
                Else
                    clipstring$ = clipstring$ & "Private "
                End If

                ' Run the "GetDeclaration" function that actually generates the full text.
                clipstring$ = clipstring$ & GetDeclaration(tableName$, DeclaresSelected(i&).DefName) & NL
            End If
        End If
        frmAPI.pctStatus.Line (0, 0)-(i& / DeclaresNo& / 3 * frmAPI.pctStatus.Width + frmAPI.pctStatus.Width * 2 / 3, frmAPI.pctStatus.Height), QBColor(9), BF
    Next i&
    CopyFunctions% = smthCopied%
End Function
Public Function CopyTypes%(tableName$, clipstring$)
    Dim tblTypes As Object, i&, j%, pstring$, smthCopied%
'**************************************
'* Types:
    frmAPI.Status = "Copying & " & tableName$ & " Types..."
    DoEvents
    Set tblTypes = frmAPI.dataAPI.Database.OpenTable(tableName$ + " Types") ' Open the table.
    tblTypes.Index = "NAME" ' Search by name.
    For i& = 0 To TypesNo& - 1
        j% = 0
        frmAPI.pctStatus.Line (0, 0)-(i& / 3 / TypesNo& * frmAPI.pctStatus.Width, frmAPI.pctStatus.Height), QBColor(9), BF
        If TypesSelected(i&).Free = False Then
            smthCopied = True
            tblTypes.Seek "=", TypesSelected(i&).DefName ' Get record.
            If tblTypes.NoMatch Then
                If Comments% Then
                    clipstring$ = clipstring$ & "'TYPE " & TypesSelected(i&).DefName & " is not available "
                    clipstring$ = clipstring$ & "in the " & tableName$ & " API." & NL
                End If
            Else
                'Public or private
                If Glbl% = True Then
                    clipstring$ = clipstring$ & "Public "
                Else
                    clipstring$ = clipstring$ & "Private "
                End If

                'Add the "Type FOOBAR" header to the string
                clipstring$ = clipstring$ & "Type " & TypesSelected(i&).DefName & NL

                'Get the first line of the type.
                pstring$ = ParseAnyString$(tblTypes("TypeInfo"), j%, Chr$(10))

                ' put the TAB (Chr$(9)) Character before every line.
                While pstring$ <> ""
                    clipstring$ = clipstring$ + Chr$(9) & pstring$ & NL
                    j% = j% + 1
                    pstring$ = ParseAnyString$(tblTypes("TypeInfo"), j%, Chr$(10))
                Wend

                'Add the "END TYPE" string and two newlines.
                clipstring$ = clipstring$ + "End Type" & NL & NL
            End If
        End If
    Next i&
    CopyTypes% = smthCopied%
End Function


' Removes all the items in lstSelected and reloads it from
' the DefInfo array give as an argument
'
' All array elements marked "free" are discarded.
'
'
Public Sub ReloadSelectedList(myArray() As DefInfo, myCount&)
'    Dim i&
'    While lstSelected.ListCount
'        lstSelected.RemoveItem 0
'    Wend
'    If myCount& = 0 Then Exit Sub
'    For i& = 0 To myCount& - 1
'        If myArray(i&).Free = False Then
'            lstSelected.AddItem myArray(i&).DefName
'        End If
'    Next i&
End Sub

' Parses a declaration based on database entries.
' Passed TableName$: Either WIN32 or WIN16
'        FuncName$: The name of the function to generate the declaration for.
'
'
Public Function GetDeclaration$(tableName$, FuncName$)
    Dim s$
    Dim quote$
    Dim FirstParam%, ParamCount%
    Dim isfunction%
    Dim dll$
    Dim tblParams As Object, tblFunctions As Object
    quote$ = """"
    Set tblFunctions = frmAPI.dataAPI.Database.OpenTable(tableName$ + " Functions")
    tblFunctions.Index = "name"
    tblFunctions.Seek "=", FuncName$
    If tableName$ = "WIN32" Then
        Set tblParams = frmAPI.dataAPI.Database.OpenRecordset("SELECT * FROM [Parameters] WHERE FUNCTIONID = " & tblFunctions("ID"))
    Else
        Set tblParams = frmAPI.dataAPI.Database.OpenRecordset("SELECT * FROM [Parameters16] WHERE FUNCTIONID = " & tblFunctions("ID"))
    End If
    s$ = "Declare "

    'Function or sub
    If tblFunctions("IsFunction") = "True" Then
        s$ = s$ & "Function "
        isfunction% = True
    Else
        s$ = s$ & "Sub "
    End If

    s$ = s$ & FuncName$
    ' Add the Function Return Type-Declaration char
    If isfunction% Then
        Select Case tblFunctions("Return")
            Case "1"
                s$ = s$ & "%"
            Case "2"
                s$ = s$ & "&"
            Case "3"
                s$ = s$ & "!"
            Case "4"
                s$ = s$ & "#"
            Case "5"
                s$ = s$ & "@"
            Case "6"
                s$ = s$ & "$"
        End Select
    End If

    s$ = s$ & " Lib "
    dll$ = tblFunctions("LIBRARY") ' Get dll name
    dll$ = LCase$(dll$)
    Select Case dll$
        Case "kernel32"
        Case "user32"
        Case "gdi32"
        Case "gdi"
        Case "kernel"
        Case "user"
        Case Else
            If InStr(dll$, ".") = 0 Then
                dll$ = dll$ & ".dll"
            End If
    End Select
    ' Add "libname"
    s$ = s$ & quote$ & dll$ & quote$
    If Len(tblFunctions("Alias")) > 0 Then ' Alias
        s$ = s$ & " Alias " & quote$ & tblFunctions("ALIAS") & quote$
    End If
    s$ = s$ & " ("
    ' Now add parameters
    If tblParams.RecordCount > 0 Then tblParams.MoveFirst
    ParamCount% = 0
    FirstParam% = True ' Read the parameters data base
    Do While Not tblParams.EOF
        If Not FirstParam% Then s$ = s$ & ", "
        ParamCount% = ParamCount% + 1
        FirstParam% = False
        If tblParams("ISBYVAL") = "True" Then s$ = s$ & "ByVal "
        s$ = s$ & tblParams("NAME")
        If tblParams("ISARRAY") = "True" Then s$ = s$ & "()"
        s$ = s$ & " As " & tblParams("TYPE")
        tblParams.MoveNext
    Loop
    s$ = s$ & ")"
    If isfunction% And tblFunctions("RETURN") = 7 Then
        s$ = s$ & " As Object"
    End If
    GetDeclaration$ = s$
End Function

'Extracts the idx%'th string from source$, where the
'substrings are separated by character sep$
'idx%=0 is the first string
Function ParseAnyString$(Source$, ByVal idx%, ByVal sep$)
    Dim nexttab%, basepos%, thispos%
    Dim res$
    basepos% = 1
    thispos% = 0
    If (Len(Source$) = 0) Then
        ParseAnyString$ = ""
        Exit Function
    End If
    Do
        nexttab% = InStr(basepos%, Source$, sep$)
        If nexttab% = 0 Then nexttab% = Len(Source$) + 1
        'Now points to next tab or 1 past end of string
        'The following should never happen
        'If nexttab% = basepos% Then GoTo ptsloop1

        If thispos% = idx% Then
            If nexttab% - basepos% - 1 < 0 Then
                res$ = ""
            Else
                res$ = Mid$(Source$, basepos%, nexttab% - basepos%)
            End If
            Exit Do
        End If
ptsloop1:
        basepos% = nexttab% + 1
        thispos% = thispos% + 1
    Loop While (basepos% <= Len(Source$))
    ParseAnyString$ = res$
End Function

'Updates the record when you click on the listbox.
'
Public Sub UpdateBoundField()
   Dim target$
   target = frmAPI.lstAPI.Text
   If target = "" Then Exit Sub
   On Error Resume Next
   frmAPI.dataAPI2.Recordset.FindFirst "Name = '" & target & "'"
End Sub