Night Owl 25/nopv25.iso/040A/INPUTB21.ZIP/INPUTBOX.BAS

BASIC Source File | 1996-12-31 | 9.3 KB | 245 lines

Attribute VB_Name = "InputBoxFunctions"
' InputBox 2.11 for Visual Basic 4.0
'
' SHAREWARE, registration is $10
' See readme.txt for more information on registration
'
' Functions to replace and enhance VB's built-in InputBox function
' ⌐1994-1997 Tuomas Salste ([e-mail])
'
' You may use, modify and distribute this source code in your programs as you wish,
' provided that
' 1. You have registered
' 2. You keep this copyright text intact
'
' **************************************************************************************************************************
' InputBox(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength)
' InputLcase(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength)
' InputUcase(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength)
' InputPassword(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength, PasswordChar)
' **************************************************************************************************************************
'
' These routines replace VB's built-in InputBox() function
'
' Load InputBox.Bas and InputBox.Frm into your project, and you are ready to
' replace the built-in InputBox with an enhanced one, automatically
' YOU DON'T HAVE TO DO ANY CODING!
'
' **************************************************************************************************************************
'
' VB's built-in InputBox function is declared like this:
' > InputBox(Prompt[, Title][, Default][, xpos][, ypos][, HelpFile, Context]) As String
' Returns a string or "" if the user pressed Cancel
'
' The new InputBox function is declared like this:
' > InputBox(Prompt[, Title][, Default][, xpos][, ypos][, HelpFile][, Context][, MaxLength]) As Variant
'
' DIFFERENCES FROM THE BUILT-IN INPUTBOX FUNCTION:
' New optional parameter MaxLength to set the maximum length of accepted input
' Returns Null if the user pressed Cancel (depends on Private Const IBValueOnCancel below)
'
' **************************************************************************************************************************
'
' NEW, ENHANCED FUNCTIONS:
' > InputUcase(Prompt[, Title][, Default][, xpos][, ypos][, HelpFile][, Context][, MaxLength]) As Variant
' Like InputBox, but turns all input to UPPER CASE
'
' > InputLcase(Prompt[, Title][, Default][, xpos][, ypos][, HelpFile][, Context][, MaxLength]) As Variant
' Like InputBox, but turns all input to lower case
'
' > InputPassword(Prompt[, Title][, Default][, xpos][, ypos][, HelpFile][, Context][, MaxLength][, PasswordChar]) As Variant
' Like InputBox, but the input is masked with * or character specified by parameter PasswordChar
'               (default mask char * depends on Private Const IBDefaultPasswordChar below)
'
'
' DEFAULT VALUES IF PARAMETERS NOT SET:
' PARAMETER       DEFAULT VALUE
' Title           App.Title
' Default         ""
' xpos            Center of parent window or screen
' ypos            Center of parent window or screen
' HelpFile        App.HelpFile
' Context         0. If set, displays a Help button
' MaxLength       None
' PasswordChar    IPDefaultPasswordChar (originally "*")

Option Explicit

' *******************************************************************************
' User defined constants
'
Private Const IBValueOnCancel = Null      ' Return value when user pressed Cancel
Private Const IBDefaultPasswordChar = "*" ' Default password mask character
#Const UseBuiltInInputBox = False         ' Set to True to disable function InputBox
'
' End of user defined constants
' *******************************************************************************


' Symbolic constants for internal use

Public Const IBUcase = &H10000
Public Const IBLcase = &H20000
Public Const IBPassword = &H40000

Public Const InputBoxVersion = 2.11
Public Const InputBoxVersionName = "InputBox 2.11"

Private Sub CenterForm(Parent As Form, Child As Form)
' Centers Child in relation to Parent

Dim x As Integer, y As Integer

x = (Parent.Left + Parent.Width / 2) - Child.Width / 2
y = (Parent.Top + Parent.Height / 2) - Child.Height / 2

Child.Move x, y

End Sub

Private Sub CenterToParent(Child As Form)
' Centers a form to its parent form

If Screen.ActiveForm Is Child Then
    ' No parent form
    CenterToScreen Child
Else
    CenterForm Forms(ParentForm(Child)), Child
End If

End Sub


Private Sub CenterToScreen(F As Form)
' Centers form F to the screen

With F
    .Move Screen.Width / 2 - .Width / 2, Screen.Height / 2 - .Height / 2
End With

End Sub


Private Function DoInputBox(ByVal Prompt As String, Optional ByVal Title As Variant, Optional ByVal Default As Variant, Optional ByVal xpos As Variant, Optional ByVal ypos As Variant, Optional ByVal HelpFile As Variant, Optional ByVal Context As Variant, Optional ByVal MaxLength As Variant, Optional ByVal Flags As Variant, Optional ByVal PasswordChar As Variant) As Variant
' Slave function to implement InputBox, InputLCase, InputUCase and InputPassword

Dim AppHelpFile As String
AppHelpFile = App.HelpFile

Load InputForm

With InputForm
    ' Set coordinates
    CenterToParent InputForm
    If IsNumeric(xpos) Then .Left = CLng(xpos)
    If IsNumeric(ypos) Then .Top = CLng(ypos)

    ' Set helpfile and context id
    If Not IsMissing(HelpFile) Then App.HelpFile = Format(HelpFile)
    If IsNumeric(Context) Then
        .HelpContextID = CLng(Context)
        .Help.Visible = True
    Else
        .HelpContextID = 0
        .Help.Visible = False
    End If

    ' Set Flags
    If Not IsMissing(Flags) Then
        ' Password
        If Flags And IBPassword Then
            If Not IsMissing(PasswordChar) And Not IsNull(PasswordChar) Then
                .Answer.PasswordChar = CStr(PasswordChar)
            Else
                .Answer.PasswordChar = IBDefaultPasswordChar
            End If
        End If
        If Flags And IBUcase Then
            .CharCase = IBUcase
        ElseIf Flags And IBLcase Then
            .CharCase = IBLcase
        Else
            .CharCase = 0
        End If
    End If

    ' Set prompt, title
    .Question = Prompt
    If Not IsMissing(Title) And Not IsNull(Title) Then
        .Caption = CStr(Title)
    Else
        .Caption = App.Title
    End If

    ' Set default string and maximum length
    If IsNumeric(MaxLength) Then
        .Answer.MaxLength = CLng(MaxLength)
        If Not IsMissing(Default) And Not IsNull(Default) Then .Answer = Left(CStr(Default), CLng(MaxLength))
    Else
        If Not IsMissing(Default) And Not IsNull(Default) Then .Answer = CStr(Default)
    End If

    ' Show the form
    .Show vbModal

    If .Tag = "OK" Then
        ' If the user pressed OK, return the Answer
        DoInputBox = .Answer
    Else
        ' If the user pressed Cancel, return Null
        DoInputBox = IBValueOnCancel
    End If
End With

Unload InputForm
App.HelpFile = AppHelpFile

End Function


#If UseBuiltInInputBox = False Then

Public Function InputBox(ByVal Prompt As String, Optional ByVal Title As Variant, Optional ByVal Default As Variant, Optional ByVal xpos As Variant, Optional ByVal ypos As Variant, Optional ByVal HelpFile As Variant, Optional ByVal Context As Variant, Optional ByVal MaxLength As Variant) As Variant
' This corresponds to VB's InputBox(prompt[, title][, default][, xpos][, ypos][, helpfile, context])

InputBox = DoInputBox(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength)

End Function

#End If

Public Function InputLCase(ByVal Prompt As String, Optional ByVal Title As Variant, Optional ByVal Default As Variant, Optional ByVal xpos As Variant, Optional ByVal ypos As Variant, Optional ByVal HelpFile As Variant, Optional ByVal Context As Variant, Optional ByVal MaxLength As Variant) As Variant
' Like InputBox but turns all input to lower case

InputLCase = DoInputBox(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength, IBLcase)

End Function

Public Function InputPassword(ByVal Prompt As String, Optional ByVal Title As Variant, Optional ByVal Default As Variant, Optional ByVal xpos As Variant, Optional ByVal ypos As Variant, Optional ByVal HelpFile As Variant, Optional ByVal Context As Variant, Optional ByVal MaxLength As Variant, Optional ByVal PasswordChar As Variant) As Variant
' Like InputBox but masks all input with PasswordChar (IBDefaultPasswordChar if PasswordChar is not set)

InputPassword = DoInputBox(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength, IBPassword, PasswordChar)

End Function

Public Function InputUCase(ByVal Prompt As String, Optional ByVal Title As Variant, Optional ByVal Default As Variant, Optional ByVal xpos As Variant, Optional ByVal ypos As Variant, Optional ByVal HelpFile As Variant, Optional ByVal Context As Variant, Optional ByVal MaxLength As Variant) As Variant
' Like InputBox but turns all input to UPPER CASE

InputUCase = DoInputBox(Prompt, Title, Default, xpos, ypos, HelpFile, Context, MaxLength, IBUcase)

End Function
Private Function ParentForm(F As Form) As Integer
' Returns the index of the parent "forms(_i_)"

Dim i As Integer
For i = 0 To Forms.Count - 1
    If Forms(i) Is Screen.ActiveForm Then
        ParentForm = i
        Exit Function
    End If
Next

End Function