Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/newrouts/newrouts.frm

Visual Basic Form | 1997-06-13 | 16.0 KB | 498 lines

VERSION 4.00
Begin VB.Form frmNewRouts
   Caption         =   "Add a new Routine"
   ClientHeight    =   3285
   ClientLeft      =   3540
   ClientTop       =   1905
   ClientWidth     =   4935
   Height          =   3975
   Icon            =   "NewRouts.frx":0000
   Left            =   3480
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   3285
   ScaleWidth      =   4935
   Top             =   1275
   Width           =   5055
   Begin VB.Frame Frame1
      Height          =   420
      Left            =   30
      TabIndex        =   15
      Top             =   0
      Width           =   4875
      Begin VB.OptionButton optSub
         Caption         =   "&Sub Procedure"
         Height          =   225
         Left            =   90
         TabIndex        =   17
         Top             =   135
         Value           =   -1  'True
         Width           =   2055
      End
      Begin VB.OptionButton optFunction
         Caption         =   "F&unction"
         Height          =   195
         Left            =   3135
         TabIndex        =   16
         Top             =   150
         Width           =   1455
      End
   End
   Begin VB.TextBox txtMaxLen
      BeginProperty Font
         name            =   "Fixedsys"
         charset         =   0
         weight          =   400
         size            =   9
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   105
      TabIndex        =   8
      Top             =   2925
      Visible         =   0   'False
      Width           =   495
   End
   Begin VB.TextBox txtSinNum
      BeginProperty Font
         name            =   "Fixedsys"
         charset         =   0
         weight          =   400
         size            =   9
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   3465
      TabIndex        =   4
      Top             =   2430
      Width           =   1305
   End
   Begin VB.TextBox txtProgName
      BeginProperty Font
         name            =   "Fixedsys"
         charset         =   0
         weight          =   400
         size            =   9
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   1110
      TabIndex        =   1
      Top             =   885
      Width           =   3645
   End
   Begin VB.ComboBox cboRetType
      BeginProperty Font
         name            =   "Fixedsys"
         charset         =   0
         weight          =   400
         size            =   9
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   345
      ItemData        =   "NewRouts.frx":0442
      Left            =   1110
      List            =   "NewRouts.frx":0467
      TabIndex        =   3
      Top             =   2430
      Width           =   1275
   End
   Begin VB.CommandButton cmdAddVariable
      Caption         =   "Add &Parameters ..."
      Height          =   345
      Left            =   3360
      TabIndex        =   5
      Top             =   2820
      Width           =   1470
   End
   Begin VB.CommandButton cmdAbort
      Caption         =   "&Abort Build"
      Height          =   345
      Left            =   2280
      TabIndex        =   7
      Top             =   2835
      Width           =   1020
   End
   Begin VB.CommandButton cmdBuild
      Caption         =   "&Build Routine"
      Height          =   330
      Left            =   1110
      TabIndex        =   6
      Top             =   2850
      Width           =   1125
   End
   Begin VB.TextBox txtDesc
      BeginProperty Font
         name            =   "Fixedsys"
         charset         =   0
         weight          =   400
         size            =   9
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   1065
      Left            =   1110
      MultiLine       =   -1  'True
      TabIndex        =   2
      Top             =   1305
      Width           =   3645
   End
   Begin VB.TextBox txtAuthor
      BeginProperty Font
         name            =   "Fixedsys"
         charset         =   0
         weight          =   400
         size            =   9
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   1110
      TabIndex        =   0
      Top             =   510
      Width           =   3645
   End
   Begin VB.Label Label6
      Caption         =   "Sin# (if any) :"
      Height          =   285
      Left            =   2565
      TabIndex        =   14
      Top             =   2445
      Width           =   885
   End
   Begin VB.Label Label5
      Caption         =   "Function"
      Height          =   225
      Left            =   75
      TabIndex        =   13
      Top             =   2250
      Width           =   855
   End
   Begin VB.Label Label4
      Caption         =   "Routine Name:"
      Height          =   390
      Left            =   45
      TabIndex        =   12
      Top             =   885
      Width           =   975
   End
   Begin VB.Label Label3
      Caption         =   "Return Type :"
      Height          =   300
      Left            =   75
      TabIndex        =   11
      Top             =   2445
      Width           =   1065
   End
   Begin VB.Label Label2
      Caption         =   "Description :"
      Height          =   345
      Left            =   75
      TabIndex        =   10
      Top             =   1305
      Width           =   990
   End
   Begin VB.Label Label1
      Caption         =   "Author :"
      Height          =   255
      Left            =   60
      TabIndex        =   9
      Top             =   480
      Width           =   1050
   End
   Begin VB.Menu mnFile
      Caption         =   "&File"
      Begin VB.Menu mnExit
         Caption         =   "&Exit"
      End
   End
   Begin VB.Menu mnHelp
      Caption         =   "&Help"
      Begin VB.Menu mnAbout
         Caption         =   "&About"
      End
   End
Attribute VB_Name = "frmNewRouts"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim retcode&
Private Sub cmdAbort_Click()
    ResetScr
    Unload Me
End Sub
Private Sub cmdAddVariable_Click()
    Dim ub%, i%
    On Error GoTo Loadfrm
    ub% = UBound(gParms())
    On Error GoTo 0
    For i = 0 To ub%
        frmAddVariables.lstVars.AddItem gParms(i)
    Next i
Loadfrm:
    frmAddVariables.Show vbModal
End Sub
Sub BuildRoutine()
    '**************************************
    '* Author : Michael J. Cox
    '* Date : 6/13/97
    '* Email : [e-mail]
    '*
    '* Desc:
    '*   This routine does all the work.
    '*   It builds a temporary ascii file and
    '*   then load it into the active form.
    '*
    '*   Modify this routine to customize the
    '*   new routine template.
    '***********************************
    On Error GoTo BuildRoutineErr
    Dim CurForm As Object, maxlen%
    Dim i%, nFileHnd%, dSub$, dDate$, oldtext$
    Dim dArgs$, dParmsDesc$(), dParms$()
    Dim dTab$, tParms%, dRetType$
    dDate = Date
    dTab$ = Space(4)
    maxlen% = gMaxLen%
    Set CurForm = gobjVBInst.ActiveProject.ActiveForm
    On Error GoTo noParms
    tParms% = UBound(gParms()) + 1
noParms:
    On Error GoTo BuildRoutineErr
    nFileHnd = FreeFile
    Open App.Path & "\Routine.txt" For Output As nFileHnd
    If gIsFunction And (cboRetType.Text) <> "" Then
        dSub$ = "Function "
        dRetType$ = " As " & Trim(cboRetType.Text)
    Else
        dSub$ = "Sub "
        dRetType$ = ""
    End If

    Print #nFileHnd, "Private " & dSub$ & Trim(txtProgName) & "(" & getArgs(tParms%) & ")" & dRetType$
    Print #nFileHnd, dTab & "'" & String(maxlen%, "*")
    Print #nFileHnd, dTab & "'* Routine Name : " & Trim(txtProgName)
    Print #nFileHnd, dTab & "'* Author Name : " & Trim(txtAuthor)
    Print #nFileHnd, dTab & "'* Date : " & dDate$
    If Trim(txtSinNum.Text) <> "" Then
        Print #nFileHnd, dTab & "'*"
        Print #nFileHnd, dTab & "'* Sin Number : " & Trim(txtSinNum.Text)
    End If
    Print #nFileHnd, dTab & "'*"
    Print #nFileHnd, dTab & "'* Description :"
    If Trim(txtDesc) = "" Then
        Print #nFileHnd, dTab & "'*     (Enter Description) "
    Else
        oldtext$ = Trim(txtDesc)
        Do While Len(oldtext$)
          Print #nFileHnd, dTab & "'*   " & Descln(oldtext$, maxlen - 4)
        Loop
    End If
    Print #nFileHnd, dTab & "'*"
    Print #nFileHnd, dTab & "'* Parameters :"
    If tParms > 0 Then
        For i = 0 To tParms - 1
          Print #nFileHnd, dTab & "'*   " & gParms(i)
        Next i
    Else
       Print #nFileHnd, dTab & "'*     (Enter Parameters) "
    End If
    Print #nFileHnd, dTab & "'*"
    Print #nFileHnd, dTab & "'* Revision History"
    Print #nFileHnd, dTab & "'* Date    Sin #       Author Id     Description     "
    Print #nFileHnd, dTab & "'* ----    ------      ---------     ----------------"
    Print #nFileHnd, dTab & "'*"
    Print #nFileHnd, dTab & "'" & String(maxlen%, "*")
    Print #nFileHnd, "On Error Goto " & Trim(txtProgName) & "Err"
    Print #nFileHnd, ""
    Print #nFileHnd, ""
    Print #nFileHnd, dTab & "Exit " & dSub$
    Print #nFileHnd, Trim(txtProgName) & "Err:"
    Print #nFileHnd, dTab & "Errorroutine$ = " & Chr(34) & Trim(txtProgName) & Chr(34)
    Print #nFileHnd, dTab & "ErrHandler Err, Errorroutine$"
    Print #nFileHnd, dTab & "Exit " & dSub$
    Print #nFileHnd, "End " & dSub$
    Close nFileHnd
    CurForm.InsertFile App.Path & "\Routine.txt"
    Kill App.Path & "\Routine.txt" 'delete the code file
    Set CurForm = Nothing
    Exit Sub
BuildRoutineErr:
    retcode = MsgBox("Error in BuildRoutine" & _
            vbCrLf & Err.Description _
        , vbCritical + vbOKOnly, "NewRouts 1.0")
End Sub
Function getArgs$(ub%)
    '**************************************
    '* Author : Michael J. Cox
    '* Date : 6/13/97
    '* Email : [e-mail]
    '*
    '* Desc:
    '*   This routine builds the parameters
    '*   from the global array gParms().
    '***********************************
    Dim i%, ret$
    If ub% = 0 Then
        Exit Function
    End If
    For i = 0 To ub - 1
      ret$ = ret$ & Trim(Mid(gParms(i), 1, 20)) & ", "
    Next i
    getArgs$ = Left(ret$, Len(ret$) - 2)
End Function
Private Sub cmdBuild_Click()
    'Check for Sub name
    If Trim(frmNewRouts.txtProgName) = "" Then
        Beep
        Exit Sub
    End If
    'Insert comments and error trap
    BuildRoutine
    'Check and save if different the Author's id
    If UCase(Trim(txtAuthor.Text)) <> UCase(Trim(gAuthorName)) And Trim(txtAuthor.Text) <> "" Then
        gAuthorName$ = Trim(txtAuthor.Text)
        SaveSetting "NewRout", "UserConf", "AuthorName", gAuthorName$
    End If
    'Check and save if different the Author's id
    If Val(UCase(Trim(txtMaxLen.Text))) <> gMaxLen% And Val(Trim(txtMaxLen.Text)) <> 0 Then
        gMaxLen = Val(Trim(txtMaxLen.Text))
        SaveSetting "NewRout", "UserConf", "MaxLen", Str$(gMaxLen%)
    End If
    'Clear Screen
    ResetScr
    'Unload Form
    Unload Me
End Sub
Sub ResetScr()
    '**************************************
    '* Author : Michael J. Cox
    '* Date : 6/13/97
    '* Email : [e-mail]
    '*
    '* Desc:
    '*   This routine clears the input
    '*   fields on the form.
    '***********************************
    txtDesc.Text = ""
    txtProgName.Text = ""
    txtSinNum.Text = ""
    cboRetType.Text = ""
    Erase gParms()
End Sub
Private Sub Form_Activate()
    SetFocus
End Sub
Private Sub Form_Load()
    '**************************************
    '* Author : Michael J. Cox
    '* Date : 6/13/97
    '* Email : [e-mail]
    '*
    '* Desc:
    '*   This form allows the user to enter
    '*   the Author name, Program Name, and
    '*   other information need to build the
    '*   Routine's shell.
    '***********************************
    'center it on the screen
    Me.Top = (Screen.Height - Me.Height) \ 2
    Me.Left = (Screen.Width - Me.Width) \ 2
End Sub
Private Sub mnAbout_Click()
    retcode = MsgBox("Add an OPICS Routine Addin" & _
            vbCrLf & "        created by         " & _
            vbCrLf & "      Michael J. Cox" & _
            vbCrLf & "Email: [e-mail]" _
        , vbInformation + vbOKOnly, "NewRouts 1.0")
End Sub
Private Sub mnExit_Click()
    ResetScr
    Unload Me
End Sub
Private Sub optFunction_Click()
    gIsFunction = True
    frmNewRouts.optFunction = True
    frmNewRouts.Caption = "Add a Function"
    frmNewRouts.cboRetType.Enabled = gIsFunction
    frmNewRouts.cboRetType.Text = ""
End Sub
Private Sub optSub_Click()
    gIsFunction = False
    frmNewRouts.optSub = True
    frmNewRouts.Caption = "Add a Sub Procedure"
    frmNewRouts.cboRetType.Enabled = gIsFunction
    frmNewRouts.cboRetType.Text = ""
End Sub
Function Descln$(oldtext$, maxln%)
    '**************************************
    '* Author : Michael J. Cox
    '* Date : 6/13/97
    '* Email : [e-mail]
    '*
    '* Desc:
    '*   This routine extracts a line of
    '*   data from the description text box.
    '*   Data is returned based on the maxlen.
    '***********************************
    Dim firstspace%, ret$
    If Len(oldtext) < 1 Then Exit Function
    firstspace% = InStr(1, oldtext$, " ")
    If firstspace% > maxln% Then
        ret$ = Mid(oldtext, 1, maxln% - 1) & "-"
        oldtext$ = Mid(oldtext, maxln%, Len(oldtext) - (maxln% - 1))
    Else
        ret$ = Mid(oldtext, 1, firstspace%)
        oldtext$ = Mid(oldtext, firstspace% + 1, Len(oldtext) - firstspace%)
        firstspace% = InStr(1, oldtext$, " ")
        Do While Len(ret$) + firstspace% <= maxln% And Len(oldtext)
          If firstspace Then
            ret$ = ret$ & Mid(oldtext, 1, firstspace%)
            If firstspace < Len(oldtext) Then
                oldtext$ = Mid(oldtext, firstspace% + 1, Len(oldtext) - firstspace%)
            Else
                oldtext$ = ""
            End If
            firstspace% = InStr(1, oldtext$, " ")
          Else
            ret$ = ret$ & oldtext
            oldtext$ = ""
          End If
        Loop
    End If
    Descln = ret$
End Function
Private Sub txtAuthor_KeyDown(KeyCode As Integer, Shift As Integer)
    '**************************************
    '* Author : Michael J. Cox
    '* Date : 6/13/97
    '* Email : [e-mail]
    '*
    '* Desc:
    '*   This routine is an Easter Egg
    '*   routine. '"SHIFT+CTRL+ALT+F2."
    '***********************************
    Dim ShiftDown, AltDown, CtrlDown, Txt
    Const vbKeyF2 = &H71    ' Define constants.
    Const vbShiftMask = 1
    Const vbCtrlMask = 2
    Const vbAltMask = 4
    ShiftDown = (Shift And vbShiftMask) > 0
    AltDown = (Shift And vbAltMask) > 0
    CtrlDown = (Shift And vbCtrlMask) > 0
    If KeyCode = vbKeyF2 Then   ' Display key combinations.
        If ShiftDown And CtrlDown And AltDown Then
            EasterEgg = True
        End If
    End If
End Sub