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/apicvt.frm

Visual Basic Form | 1997-02-17 | 16.2 KB | 480 lines

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form frmCVT
   Caption         =   "VB Declaration File to Database Converter"
   ClientHeight    =   3645
   ClientLeft      =   1095
   ClientTop       =   1770
   ClientWidth     =   6120
   BeginProperty Font
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3645
   ScaleWidth      =   6120
   Begin VB.CheckBox chkAPICat
      Caption         =   "Use Win32API Categories"
      Height          =   315
      Left            =   2280
      TabIndex        =   8
      Top             =   2220
      Value           =   1  'Checked
      Width           =   2595
   End
   Begin VB.CheckBox chkUpdate
      Caption         =   "Update Mode"
      Height          =   255
      Left            =   300
      TabIndex        =   7
      Top             =   2220
      Value           =   1  'Checked
      Width           =   1695
   End
   Begin VB.Timer tmrConvert
      Enabled         =   0   'False
      Interval        =   100
      Left            =   5640
      Top             =   240
   End
   Begin VB.CommandButton cmdGO
      Caption         =   "Go"
      Enabled         =   0   'False
      Height          =   495
      Left            =   3240
      TabIndex        =   5
      Top             =   1320
      Width           =   1095
   End
   Begin VB.Frame Frame1
      Caption         =   "Source API"
      Height          =   1155
      Left            =   240
      TabIndex        =   2
      Top             =   960
      Width           =   2055
      Begin VB.CheckBox chkWin16
         Caption         =   "WIN16"
         Enabled         =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   4
         Top             =   660
         Width           =   1575
      End
      Begin VB.CheckBox chkWin32
         Caption         =   "WIN32"
         Enabled         =   0   'False
         Height          =   255
         Left            =   120
         TabIndex        =   3
         Top             =   300
         Value           =   1  'Checked
         Width           =   1755
      End
   End
   Begin MSComDlg.CommonDialog CMDialog1
      Left            =   5340
      Top             =   720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   327680
      CancelError     =   -1  'True
   End
   Begin VB.Label lblCurrentLine
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BackStyle       =   0  'Transparent
      ForeColor       =   &H80000008&
      Height          =   855
      Left            =   240
      TabIndex        =   6
      Top             =   2640
      Width           =   5715
   End
   Begin VB.Label lblSRCFile
      BackStyle       =   0  'Transparent
      Caption         =   "No Source File Specified"
      Height          =   255
      Left            =   240
      TabIndex        =   1
      Top             =   480
      Width           =   4995
   End
   Begin VB.Label lblDBFile
      BackStyle       =   0  'Transparent
      Caption         =   "No Database File Specified"
      Height          =   255
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   5355
   End
   Begin VB.Menu mnuFile
      Caption         =   "File"
      Begin VB.Menu mnuSelectDB
         Caption         =   "Select Database"
      End
      Begin VB.Menu mnuSelectSRC
         Caption         =   "Select Source"
      End
   End
   Begin VB.Menu CmdAbout
      Caption         =   "About"
      NegotiatePosition=   3  'Right
   End
Attribute VB_Name = "frmCVT"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Copyright (c) 1996 by Desaware
' Part of the Desaware API Toolkit
' All Rights Reserved
Option Explicit
Dim db As Database
Dim tblCategories As Table
Dim tblParameters As Table
Dim tblConstants As Table
Dim tblFunctions As Table
Dim tblTypes As Table
Dim APIdb As Database   ' Windows reference database
Dim tblAPI As Table     ' Windows Win32API table
Const WINAPIDB$ = "win32api.mdb"
Const DELETEPARAMS$ = "DELETE FROM [Parameters] WHERE Parameters!FUNCTIONID = "
Const DELETEPARAMS16$ = "DELETE FROM [Parameters16] WHERE Parameters16!FUNCTIONID = "
Private Sub AddCurrentObject()
    Dim ctr%
    Dim catid%
    Dim typedef$
    Dim oldid&
    Select Case objType
        Case 0
        Case 1, 2   ' Function or sub
                ' Prevent duplicates
                oldid& = 0
                tblFunctions.Seek "=", objName$
                If Not tblFunctions.NoMatch Then
                    If chkUpdate.Value <> 1 Then ' Warn on duplicates
                        CvtResult$ = CvtResult$ & "Duplicate Function: " & objName$ & CRLF$
                        Exit Sub
                    Else
                        tblFunctions.Edit
                        oldid& = tblFunctions!ID
                    End If
                Else
                    tblFunctions.AddNew
                End If
                tblFunctions!Name = objName$
                ' Filter out aliases that exactly match the function name
                If objAlias$ <> "" And objAlias$ <> objName$ Then
                    tblFunctions!ALIAS = objAlias$
                Else
                    tblFunctions!ALIAS = Null
                End If
                tblFunctions!LIBRARY = objLib$
                If objType = 1 Then
                    tblFunctions!ISFUNCTION = False
                    tblFunctions!RETURN = 0
                Else
                    tblFunctions!ISFUNCTION = True
                    tblFunctions!RETURN = objReturn%
                End If
                catid% = GetCategoryID(objName$, objAlias$)
                If catid% >= 0 Then
                    tblFunctions.Fields("CATEGORY") = catid%
                Else
                    tblFunctions.Fields("CATEGORY") = 0
                End If
                tblFunctions.Update
                tblFunctions.Bookmark = tblFunctions.LastModified
                ' Delete any existing entries for this one

                If oldid& > 0 Then
                    If chkWin32.Value = 1 Then
                        db.Execute DELETEPARAMS$ & oldid&
                    Else
                        db.Execute DELETEPARAMS16$ & oldid&
                    End If
                End If

                For ctr = 1 To UBound(pDesc)
                    tblParameters.AddNew
                    tblParameters!Name = pDesc(ctr).ParamName
                    tblParameters!Type = pDesc(ctr).paramType
                    tblParameters!IsArray = pDesc(ctr).IsArray
                    tblParameters!IsByVal = pDesc(ctr).IsByVal
                    tblParameters!FUNCTIONID = tblFunctions!ID
                    tblParameters.Update
                Next ctr


        Case 3  ' Type
                ' Prevent duplicates
                typedef$ = ""
                tblTypes.Seek "=", objName$
                If Not tblTypes.NoMatch Then
                    If chkUpdate.Value <> 1 Then ' Warn on duplicates
                        CvtResult$ = CvtResult$ & "Duplicate Type: " & objName$ & CRLF$
                        Exit Sub
                    Else
                        tblTypes.Edit
                    End If
                Else
                    tblTypes.AddNew
                End If
                tblTypes!Name = objName$
                catid% = GetCategoryID(objName$, "")
                If catid% >= 0 Then tblTypes.Fields("CATEGORY") = tblCategories!ID
                For ctr = 1 To UBound(pDesc)
                    typedef$ = typedef$ & pDesc(ctr).ParamName & Chr$(10)
                Next ctr
                tblTypes!TYPEINFO = typedef$
                tblTypes.Update


        Case 4      ' Constant
                tblConstants.Seek "=", objName$
                If Not tblConstants.NoMatch Then
                    If chkUpdate.Value <> 1 Then ' Warn on duplicates
                        CvtResult$ = CvtResult$ & "Duplicate Constant: " & objName$ & CRLF$
                        Exit Sub
                    Else
                        tblConstants.Edit
                    End If
                Else
                    tblConstants.AddNew
                End If
                tblConstants!Name = objName$
                tblConstants!Type = objReturn%
                tblConstants!Value = objLib$

                catid% = GetCategoryID(objName$, "")
                If catid% >= 0 Then tblConstants.Fields("CATEGORY") = tblCategories!ID
                tblConstants.Update
    End Select
End Sub
' Enable/Disable controls as needed
Private Sub CheckEnables()
    Dim SetEnables As Integer
    If tmrConvert.Enabled Then
        chkWin32.Enabled = False
        chkWin16.Enabled = False
        mnuFile.Enabled = False
        cmdGO.Enabled = True
        Exit Sub
    End If

    mnuFile.Enabled = True
    SetEnables = TargetDataBase$ <> "" And SourceFileName$ <> ""
    chkWin32.Enabled = SetEnables
    chkWin16.Enabled = SetEnables
    cmdGO.Enabled = SetEnables And (chkWin32.Value = 1 Or chkWin16.Value = 1)
End Sub
' In update mode, existing functions are updated according
' to the current entry - this allows update based on the
' text file.
Private Sub chkUpdate_Click()
End Sub
Private Sub chkWin16_Click()
    If chkWin16.Value = 1 Then chkWin32.Value = 0 Else chkWin32.Value = 1
    CheckEnables
End Sub
Private Sub chkWin32_Click()
    If chkWin32.Value = 1 Then chkWin16.Value = 0 Else chkWin16.Value = 1
    CheckEnables
End Sub
Private Sub CmdAbout_Click()
    frmAbout.Show 1
End Sub
Private Sub cmdGO_Click()
    If tmrConvert.Enabled Then DoConversion 2 Else DoConversion 1
End Sub
' Perform the conversion
'   startit% is set 1 on first call
'   startit% is set to 2 to abort
Private Sub DoConversion(ByVal startit%)
    Static FileHandle%
    Dim src$
    Dim parseres%
    If startit% = 1 And tmrConvert.Enabled Then
        MsgBox "File Conversion is already in progress"
        Exit Sub
    End If
    If startit% = 1 Then
        FileHandle% = FreeFile
        On Error GoTo FileErr
        Open SourceFileName$ For Input Access Read As #FileHandle%
        On Error GoTo 0
        tmrConvert.Enabled = True
        cmdGO.Caption = "Stop"
        CheckEnables
        CvtResult$ = ""
        Set tblCategories = db.OpenTable("Categories")
        tblCategories.Index = "DESCRIPTION"
        If chkWin32.Value = 1 Then
            Set tblParameters = db.OpenTable("Parameters")
            Set tblTypes = db.OpenTable("WIN32 Types")
            Set tblFunctions = db.OpenTable("WIN32 Functions")
            Set tblConstants = db.OpenTable("WIN32 Constants")
        Else
            Set tblParameters = db.OpenTable("Parameters16")
            Set tblTypes = db.OpenTable("WIN16 Types")
            Set tblFunctions = db.OpenTable("WIN16 Functions")
            Set tblConstants = db.OpenTable("WIN16 Constants")
        End If
        tblTypes.Index = "NAME"
        tblFunctions.Index = "NAME"
        tblConstants.Index = "NAME"
        tblParameters.Index = "FUNCTIONID"
    End If
    If tmrConvert.Enabled = False Then Exit Sub
    If EOF(FileHandle%) Or startit% = 2 Then
        Close FileHandle%
        ' Process rest of end conditon
        tmrConvert.Enabled = False
        cmdGO.Caption = "Go"
        CheckEnables

        Set tblCategories = Nothing
        Set tblParameters = Nothing
        Set tblTypes = Nothing
        Set tblFunctions = Nothing
        Set tblConstants = Nothing
        If CvtResult$ <> "" Then frmResults.Show 1
        Exit Sub
    End If

    Line Input #FileHandle%, src$
    lblCurrentLine.Caption = src$
    lblCurrentLine.Refresh
    parseres% = am1ParseLine(src$)
    Select Case parseres%
        Case 0  ' Object not complete
        Case 1  ' Add information to database here
                AddCurrentObject

        Case 2  ' Syntax error
                CvtResult$ = CvtResult$ & src$ & CRLF$
    End Select
    Exit Sub
FileErr:
    MsgBox Error
    Exit Sub
End Sub
Private Sub Form_Load()
    Dim apidbase$
    CRLF$ = Chr$(13) & Chr$(10)
    apidbase$ = App.Path
    If Right$(apidbase$, 1) <> "\" Then apidbase$ = apidbase$ & "\"
    apidbase$ = apidbase$ & WINAPIDB$
    If Len(Dir$(apidbase$)) > 0 And chkAPICat.Value = 1 Then
        Set APIdb = OpenDatabase(apidbase$)
        Set tblAPI = APIdb.OpenTable("WIN32API")
        tblAPI.Index = "Element Name"
    End If
    am1Initialize
End Sub
'   Attempt to retreive a category name from the WinAPI reference
Private Function GetAPICategory$(apiname$, aliasname$)
    tblAPI.Seek "=", apiname$
    If tblAPI.NoMatch Then
        GetAPICategory$ = ""
        Exit Function
    End If
    tblAPI.Edit
    If Not IsNull(tblAPI!Subsystem) Then
        GetAPICategory$ = tblAPI!Subsystem
    Else
        If Len(aliasname$) > 0 Then
            tblAPI.Seek "=", aliasname$
            If tblAPI.NoMatch Then
                GetAPICategory$ = ""
            Else
                tblAPI.Edit
                If Not IsNull(tblAPI!Subsystem) Then GetAPICategory$ = tblAPI!Subsystem Else GetAPICategory$ = ""
            End If
        Else
            GetAPICategory$ = ""
        End If
    End If
End Function
' Returns the category ID to use, -1 if none
Private Function GetCategoryID(ByVal elementname$, ByVal aliasname$) As Long
    If chkAPICat.Value = 1 Then
        If tblAPI Is Nothing Then
            GetCategoryID = -1
            Exit Function
        End If
        Category$ = GetAPICategory$(elementname$, aliasname$)
    End If
    If Category$ <> "" Then
        tblCategories.Seek "=", Category$
        If tblCategories.NoMatch Then
            tblCategories.AddNew
            tblCategories!Description = Category$
            tblCategories.Update
            tblCategories.Bookmark = tblCategories.LastModified
        End If
        GetCategoryID = tblCategories!ID
    Else
        GetCategoryID = -1
    End If
End Function
Private Sub mnuSelectDB_Click()
    Dim f$
    CMDialog1.Filter = "Database|*.MDB"
    CMDialog1.Flags = OFN_CREATEPROMPT Or OFN_HIDEREADONLY
    CMDialog1.DefaultExt = "*.MDB"
    On Error GoTo cancelled
    CMDialog1.Action = 1
    f$ = CMDialog1.filename
    On Error GoTo NoTemplate
    If Len(Dir$(f$)) = 0 Then   ' New file
        FileCopy App.Path & "\" & "apitmpl.mdb", f$
    End If
    On Error GoTo NoDatabase
    Set db = OpenDatabase(f$)
    TargetDataBase$ = f$
    lblDBFile.Caption = "Database: " & TargetDataBase$
    CheckEnables
    Exit Sub
NoDatabase:
    MsgBox "Unable to open specified database"
    Resume cancelled
NoTemplate:
    MsgBox "Unable to copy from template database"
cancelled:
    lblDBFile.Caption = "No Database File Specified"
    Exit Sub
End Sub
Private Sub mnuSelectSRC_Click()
    Dim f$
    CMDialog1.Filter = "Text files|*.TXT|VB Modules|*.BAS"
    CMDialog1.Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
    CMDialog1.DefaultExt = "*.TXT"
    On Error GoTo cancelled2
    CMDialog1.Action = 1
    f$ = CMDialog1.filename
    SourceFileName$ = f$
    lblSRCFile.Caption = "Source File: " & SourceFileName$
    CheckEnables
    Exit Sub
cancelled2:
    lblSRCFile.Caption = "No Source File Specified"
    Exit Sub
End Sub
Private Sub tmrConvert_Timer()
    Dim cnt%
    For cnt% = 1 To 10
        DoConversion 0
    Next cnt%
End Sub