VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "LibBuild"
   ClientHeight    =   5940
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5985
   ClipControls    =   0   'False
   ControlBox      =   0   'False
   FillStyle       =   0  'Solid
   FontTransparent =   0   'False
   Icon            =   "_LibBuild.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   NegotiateMenus  =   0   'False
   ScaleHeight     =   5940
   ScaleWidth      =   5985
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton eClose 
      Cancel          =   -1  'True
      Caption         =   "&Close"
      CausesValidation=   0   'False
      Height          =   375
      Left            =   4680
      TabIndex        =   3
      Top             =   5520
      Width           =   1215
   End
   Begin VB.CommandButton eRetry 
      Caption         =   "&Retry"
      CausesValidation=   0   'False
      Default         =   -1  'True
      Height          =   375
      Left            =   3360
      TabIndex        =   2
      Top             =   5520
      Width           =   1215
   End
   Begin VB.ListBox eList 
      CausesValidation=   0   'False
      Height          =   4935
      Left            =   120
      TabIndex        =   0
      Top             =   480
      Visible         =   0   'False
      Width           =   5775
   End
   Begin VB.Label eLabel 
      Height          =   240
      Left            =   480
      TabIndex        =   1
      Top             =   120
      Width           =   5415
   End
   Begin VB.Image eIcon 
      Height          =   240
      Left            =   120
      Top             =   120
      Width           =   240
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 0

Private SecondBuilds As Boolean
Private Api(999) As String
Private ApiP(999) As Boolean
Private ApiU(999) As Boolean
Private ApiCount As Long

Private MyFuncs As String

Private xAPI(9999) As String
Private xApiDef(9999) As String
'Private xApiUnCheck(9999) As Boolean
Private xApiIsStruc(9999) As Boolean
Private xAPICount As Long

Private Inc(999) As String
Private IncP(999) As Boolean
Private IncCount As Long

Private CDr(999) As String
Private CDrP(999) As Boolean ' not really needed
Private CDrCount As Long

Private MyDefines As String

Private HeightDiff As Long
Private HasError As Boolean
Private HasWarning As Boolean
'Private IsWorking As Boolean







'Private xAPI(9999) As String
Private xAPIM(9999) As String
Private xAPIL(9999) As Long
Private xAPIW(9999) As String
Private xAPICountN As Long

Private Function xTry(ByVal StrLft As String, ByVal xStr As String, ByVal xLine As Long, ByVal xMod As String) As Boolean
  Dim xLong1 As Long
'  Dim StrOther As String

  'Stop
  If LCase(Left(xStr, Len(StrLft))) = StrLft Then
'    Stop
    xTry = True
    xLong1 = InStr(Len(StrLft) + 1&, xStr, " ")
    If xLong1 = 0& Then xLong1 = Len(xStr) + 1&
'    StrOther = Mid(xStr, xLong1 + 13&)
    StrLft = Mid(xStr, Len(StrLft) + 1&, xLong1 - Len(StrLft) - 1&)
    xStr = LCase(StrLft)
    
    For xLong1 = 0& To xAPICountN - 1&
      If Len(xAPI(xLong1)) = Len(xStr) Then
        If xAPI(xLong1) = xStr Then
          If xAPIL(xLong1) = 0& Then
            xAPIW(xLong1) = xAPIW(xLong1) + vbCrLf + "  " + xMod + " in line " + CStr(xLine)
            Else
            xAPIW(xLong1) = StrLft + vbCrLf + "  " + xAPIM(xLong1) + " in line " + CStr(xAPIL(xLong1)) + vbCrLf + "  " + xMod + " in line " + CStr(xLine)
            xAPIL(xLong1) = 0&
            End If
          GoTo UnFor
          End If
        End If
      Next
    'Stop
'    If Right(StrLft, 1&) = "W" Then
'      'Stop
'      If Not InStr(1&, StrOther, " as any", vbTextCompare) = 0& Then
'        SetWarning "  Parameter missmatch in " + StrLft
'        End If
'      End If
    xAPI(xAPICountN) = xStr
    xAPIL(xAPICountN) = xLine
    xAPIM(xAPICountN) = xMod
    xAPICountN = xAPICountN + 1&
UnFor:
    End If
'Stop
  End Function

Private Sub xCheck(ByVal xFile As String)
  Dim xLine As Long
  Dim xChar1 As String

  xFile = Trim(Mid(xFile, InStr(xFile, ";") + 1&))
  SubLog "Checking: " + xFile
  On Error GoTo Er1
  Open xFile For Input As 2
  On Error GoTo Er2
  Do Until EOF(2)
    Line Input #2, xChar1
    On Error GoTo 0
    xChar1 = LTrim(xChar1)
    xLine = xLine + 1&
'    Stop
    On Error GoTo Er3
    If xTry("private declare sub ", xChar1, xLine, xFile) Then
      ElseIf xTry("public declare sub ", xChar1, xLine, xFile) Then
      ElseIf xTry("declare sub ", xChar1, xLine, xFile) Then
      ElseIf xTry("private declare function ", xChar1, xLine, xFile) Then
      ElseIf xTry("public declare function ", xChar1, xLine, xFile) Then
      ElseIf xTry("declare function ", xChar1, xLine, xFile) Then
      ElseIf xTry("private type ", xChar1, xLine, xFile) Then
      ElseIf xTry("public type ", xChar1, xLine, xFile) Then
      ElseIf xTry("type ", xChar1, xLine, xFile) Then
      Else
      End If
    Loop
Rs1:
  On Error GoTo 0
  Close 2
  Exit Sub

Er1:
  SetError "  Error opening " + xFile
  Resume Rs1
  
Er2:
  SetError "  Error reading " + xFile
  Resume Rs1
  
Er3:
  SetError "  Error processing " + xFile
  Resume Rs1
  End Sub

Private Sub CmbLine(ByRef xData() As String, ByRef xPublic() As Boolean, ByRef xCount As Long, ByVal xChar1 As String, ByVal MkPublic As Boolean)
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xChar2 As String

  xChar2 = LCase(xChar1)
  xLong2 = Len(xChar1)
  For xLong1 = 0& To xCount - 1&
    If Len(xData(xLong1)) = xLong2 Then
      If LCase(xData(xLong1)) = xChar2 Then
        If MkPublic Then xPublic(xLong1) = True
        Exit Sub
        End If
      End If
    Next
  xData(xCount) = xChar1
  xPublic(xCount) = MkPublic
  xCount = xCount + 1&
  End Sub

Private Sub RealCombine(ByVal xChar1 As String, ByVal MkPublic As Boolean)
  Dim xMode As Long

  On Error GoTo Er1
  Open xChar1 For Input As 1
  On Error GoTo Er2
  Do Until EOF(1)
    Line Input #1, xChar1
    On Error GoTo Er3
    If Not Len(xChar1) = 0& Then
      Select Case UCase(xChar1)
        Case "[API]"
          xMode = 0&
        Case "[INCLUDE]"
          xMode = 1&
        Case "[DIRECTIVE]"
          xMode = 2&
        Case "[DEFINE]"
          xMode = 3&
        Case "[CODE]"
          Do Until EOF(1)
            Line Input #1, xChar1
            MyFuncs = MyFuncs + vbCrLf + xChar1
            Loop
          If Not Right(MyFuncs, 4&) = vbCrLf + vbCrLf Then
            MyFuncs = MyFuncs + vbCrLf
            End If
          Exit Do
        Case Else
          Select Case xMode
            Case 0&
              If LCase(Left(xChar1, 7&)) = "public " Then
                CmbLine Api(), ApiP(), ApiCount, Mid(xChar1, 8), True
                Else
                CmbLine Api(), ApiP(), ApiCount, xChar1, MkPublic
                End If
            Case 1&
              CmbLine Inc(), IncP(), IncCount, xChar1, False
            Case 2&: CmbLine CDr(), CDrP(), CDrCount, xChar1, False
            Case 3&: MyDefines = MyDefines + vbCrLf + xChar1
            End Select
        End Select
      End If
    On Error GoTo Er2
    Loop
  
Rs1:
  On Error GoTo 0
  Close 1
  Exit Sub
  
Er1:
  SetError "  Error opening file" ': " + xChar1
  Resume Rs1
  
Er2:
  SetError "  Error reading file" ': " + xChar1
  Resume Rs1
  
Er3:
  SetError "  Error processing data"
  Resume Rs1
  End Sub

Private Sub RealWriteTo(ByVal xMode As Boolean)
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xLong3 As Long

  For xLong1 = 0& To ApiCount - 1&
    xLong3 = Len(Api(xLong1))
    For xLong2 = 0& To xAPICount - 1&
      If xApiIsStruc(xLong2) = xMode Then
        If xLong3 = Len(xApiDef(xLong2)) Then
          If LCase(Api(xLong1)) = xApiDef(xLong2) Then
            If ApiP(xLong1) Then
              Print #1, "Public " + xAPI(xLong2)
              Else
              Print #1, "Private " + xAPI(xLong2)
              End If
            ApiU(xLong1) = True
            End If
          End If
        End If
      Next
    Next
  End Sub

Public Sub BuildLib(ByVal PrjFile As String, ByVal Filename As String, ByVal ModName As String)
  Dim xLong1 As Long
  Dim xLong2 As Long
  Dim xLong3 As Long
  Dim xLong4 As Long
  Dim xChar2 As String
  Dim xChar3 As String
  Dim xChar4 As String
  Dim xApiUnCheck As Boolean

  If SecondBuilds And HasError Or HasWarning Then Exit Sub
  SecondBuilds = True

  'IsWorking = True
  eRetry.Enabled = False
  eClose.Enabled = False
  eLabel.Caption = ""
  eList.Clear
  If HasError Or HasWarning Then
    eList.Visible = False
    ReCenter -HeightDiff
    HasError = False
    HasWarning = False
    End If
  DoEvents

  If LCase(Right(Filename, 4&)) = ".def" Then
    MainLog "Processing: " + Mid(Filename, InStrRev(Filename, "\") + 1&)
    RealCombine Filename, True
    If Not HasError Then
      Do Until (xLong1 = IncCount)
        MainLog "Including: " + Inc(xLong1)
        RealCombine "d:\dev\software\common\vb6\gen_" + Inc(xLong1) + ".inc", False
        If HasError Then Exit Do
        xLong1 = xLong1 + 1&
        Loop
      If Not HasError Then
        MainLog "Loading API definitions"
        Open "d:\dev\software\common\vb6\api.def" For Input As 1
        Do Until EOF(1)
          Line Input #1, xChar2
          If Left(xChar2, 1) = "!" Then
            'xApiUnCheck(xAPICount) = True
            xApiUnCheck = True
            xChar2 = Mid(xChar2, 2&)
            Else
            'xApiUnCheck(xAPICount) = False
            xApiUnCheck = False
            End If
          If Not Len(xChar2) = 0& Then
            xLong1 = InStr(xChar2, " ")
            xLong3 = InStr(xLong1 + 1&, xChar2, " ")
            xChar4 = Mid(xChar2, xLong1 + 1&, xLong3 - xLong1 - 1&)
            'xChar3 = LCase(Mid(xChar2, xLong1 + 1&, xLong3 - xLong1 - 1&))
            xChar3 = LCase(xChar4)
            xLong4 = Len(xChar3)
            For xLong2 = 0& To xAPICount - 1&
              If Len(xAPI(xLong2)) = xLong4 Then If xAPI(xLong2) = xChar3 Then GoTo UnFor
              Next
            Select Case LCase(Left(xChar2, xLong1 - 1&))
              Case "function"
                'xApiIsStruc(xApiCount) = False
                xAPI(xAPICount) = "Declare " + xChar2
                GoTo CheckWStuff
              Case "sub"
                'xApiIsStruc(xApiCount) = false
                xAPI(xAPICount) = "Declare " + xChar2
CheckWStuff:
                'Stop
                Select Case Asc(Right(xChar4, 1&))
                  Case 65&, 87& '"A", "W"
                    If Not InStr(1&, Mid(xChar2, xLong3 + 5), " as any", vbTextCompare) = 0& Then
                      If Not xApiUnCheck Then
                        SetWarning "  Parameter missmatch in " + xChar4
                        End If
                      End If
                  End Select

              Case "type"
                xApiIsStruc(xAPICount) = True
        '        Stop
                xAPI(xAPICount) = Left(xChar2, xLong3 - 1&) + vbCrLf + "  " + Replace(Mid(xChar2, xLong3 + 2&, Len(xChar2) - xLong3 - 2), ", ", vbCrLf + "  ") + vbCrLf + "  End Type"
              End Select
            xApiDef(xAPICount) = xChar3
            xAPICount = xAPICount + 1&
            End If
UnFor:
          Loop
        Close 1
        
        MainLog "Creating output file"
        'Stop
        Open Left(Filename, Len(Filename) - 3&) + "bas" For Output As 1
        Print #1, "Attribute VB_Name = " + Chr(34) + ModName + Chr(34)
        Print #1, "Option Explicit"
        Print #1, "Option Base 0"
        Print #1, ""
      
        If Not CDrCount = 0& Then
          For xLong1 = 0& To CDrCount - 1&
            Print #1, "#Const " + CDr(xLong1) + " = True"
            Next
          Print #1, ""
          End If
        If Not IncCount = 0& Then
          For xLong1 = 0& To IncCount - 1&
            Print #1, "#Const " + Inc(xLong1) + " = True"
            Next
          Print #1, ""
          End If
      
        SubLog "  Types"
        RealWriteTo 1&
        Print #1, ""
        SubLog "  Subs and Functions"
        RealWriteTo 0&
        Print #1, ""
        Print #1, MyDefines
        Print #1, MyFuncs
        Close 1

        MainLog "Checking for missing API declarations"
        For xLong1 = 0& To ApiCount - 1&
          If Not ApiU(xLong1) Then
            SetError "  " + Api(xLong1)
            End If
          Next

        Erase xAPI()
        MainLog "Checking for multiple API declarations"
        On Error GoTo Er1
        Open PrjFile For Input As 1
        On Error GoTo Er2
        Do Until EOF(1)
          Line Input #1, xChar2
          On Error GoTo 0
          If Left(xChar2, 7&) = "Module=" Then
            Call xCheck(Mid(xChar2, 8&))
            ElseIf Left(xChar2, 5&) = "Form=" Then
            Call xCheck(Mid(xChar2, 6&))
            ElseIf Left(xChar2, 6&) = "Class=" Then
            Call xCheck(Mid(xChar2, 7&))
            ElseIf Left(xChar2, 12&) = "UserControl=" Then
            Call xCheck(Mid(xChar2, 13&))
            End If
          On Error GoTo Er2
          Loop
        Close 1
      
        For xLong1 = 0& To xAPICountN - 1&
          If Not Len(xAPIW(xLong1)) = 0& Then
            SetErrorEx xAPIW(xLong1)
            End If
          Next
        End If
      End If
    End If

Rs1:
  On Error GoTo 0
  Close 1
  'HasError = True
  eClose.Enabled = True
  eRetry.Enabled = True
  If HasError Or HasWarning Then
    eList.Visible = True
    ReCenter HeightDiff
    eRetry.Default = True
    On Error Resume Next
    eRetry.SetFocus
    On Error GoTo 0
    Else
    MainLog CStr(IncCount) + " includes, " + CStr(ApiCount) + "/" + CStr(xAPICount) + " APIs, " + CStr(CDrCount) + " directives, " + MkKB(Len(MyDefines)) + " declarations, " + MkKB(Len(MyFuncs)) + " code"
    eClose.Default = True
    On Error Resume Next
    eClose.SetFocus
    On Error GoTo 0
    End If
  'IsWorking = False
  Exit Sub
  
Er1:
  SetError "  Error opening project file"
  Resume Rs1
  
Er2:
  SetError "  Error reading project file"
  Resume Rs1
  End Sub

Private Function MkKB(ByVal xLong1 As Long) As String
  MkKB = CStr(Fix((xLong1 + 500&) / 1000&)) + "kb"
  End Function

Private Sub MainLog(ByVal xChar1 As String)
  eLabel.Caption = xChar1
  eLabel.Refresh
  eList.AddItem xChar1
  'DoEvents
  End Sub

Private Sub SubLog(ByVal xChar1 As String)
  eList.AddItem xChar1
  End Sub

Private Sub SetError(ByVal xChar1 As String)
  HasError = True
  eList.AddItem xChar1
  End Sub

Private Sub SetWarning(ByVal xChar1 As String)
  HasWarning = True
  eList.AddItem xChar1
  End Sub

Private Sub SetErrorEx(ByVal xChar1 As String)
  Dim xLong1 As Long
  
  HasError = True
  Do
    xLong1 = InStr(xChar1, vbCrLf)
    If xLong1 = 0& Then Exit Do
    eList.AddItem Left(xChar1, xLong1 - 1&)
    xChar1 = Mid(xChar1, xLong1 + 2&)
    Loop
  eList.AddItem xChar1
  End Sub

Private Sub eClose_Click()
  Unload Me
  End Sub

Private Sub eRetry_Click()
  CleanUp
  Main
  SecondBuilds = False
  HasWarning = False
  End Sub

Public Sub CleanUp()
  Erase Api()
  Erase ApiP()
  Erase ApiU()
  ApiCount = 0&
  MyFuncs = ""
  Erase xAPI()
  Erase xApiDef()
  Erase xApiIsStruc()
  xAPICount = 0&
  Erase Inc()
  Erase IncP()
  IncCount = 0&
  Erase CDr()
  CDrCount = 0
  MyDefines = ""
  
  'Erase xAPI()
  Erase xAPIM()
  Erase xAPIL()
  Erase xAPIW()
  xAPICountN = 0&
  End Sub

Private Sub Form_Load()
  HeightDiff = eRetry.Top - eList.Top
  eIcon.Picture = Me.Icon
  ReCenter -HeightDiff
  Visible = True
  End Sub

Private Sub ReCenter(ByVal xLong1 As Long)
  eRetry.Top = eRetry.Top + xLong1
  eClose.Top = eClose.Top + xLong1
  Me.Height = Me.Height + xLong1
  'Stop
  'xLong1 = Me.Height + xLong1
  'Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - xLong1) \ 2, Me.Width, xLong1
  End Sub

'Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  'If UnloadMode = 0 And IsWorking Then
  '  Cancel = 1
  '  End If
'  End Sub

