DP Tool Club 24/CD_ASCQ_24_0995.iso/win/prg/vbstra/demoapp/strdllap.frm

Text File | 1995-06-23 | 19KB | 726 lines

VERSION 2.00
Begin Form StrDLLApp
   BackColor       =   &H00C0C0C0&
   Caption         =   "VBstrAPI.DLL Demonstrator"
   ClientHeight    =   5985
   ClientLeft      =   45
   ClientTop       =   1410
   ClientWidth     =   8070
   Height          =   6390
   Icon            =   STRDLLAP.FRX:0000
   Left            =   -15
   LinkTopic       =   "Form1"
   ScaleHeight     =   5985
   ScaleWidth      =   8070
   Top             =   1065
   Width           =   8190
   Begin ListBox List
      BackColor       =   &H00808000&
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   1605
      Left            =   5520
      TabIndex        =   8
      Tag             =   "OL"
      Top             =   270
      Width           =   2475
   End
   Begin TextBox Monitor
      BackColor       =   &H00C0C0C0&
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   675
      Left            =   150
      MousePointer    =   1  'Arrow
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   1
      Tag             =   "OL"
      Top             =   1980
      Width           =   5265
   End
   Begin PictureBox ToolBar
      BackColor       =   &H00808000&
      Height          =   1875
      Left            =   0
      ScaleHeight     =   1845
      ScaleWidth      =   5400
      TabIndex        =   0
      Tag             =   "OL"
      Top             =   0
      Width           =   5430
      Begin PictureBox Picture1
         AutoSize        =   -1  'True
         BorderStyle     =   0  'None
         Height          =   1800
         Left            =   2970
         Picture         =   STRDLLAP.FRX:0302
         ScaleHeight     =   1800
         ScaleWidth      =   2400
         TabIndex        =   7
         Top             =   30
         Width           =   2400
      End
      Begin SSCommand biQuit
         Caption         =   "&Exit"
         Font3D          =   1  'Raised w/light shading
         ForeColor       =   &H00000000&
         Height          =   1800
         Left            =   2250
         Picture         =   STRDLLAP.FRX:28FC
         RoundedCorners  =   0   'False
         TabIndex        =   6
         Top             =   30
         Width           =   705
      End
      Begin SSCommand biArray
         Caption         =   "&ArrayStr"
         Font3D          =   1  'Raised w/light shading
         Height          =   900
         Left            =   1140
         Picture         =   STRDLLAP.FRX:2B66
         RoundedCorners  =   0   'False
         TabIndex        =   5
         Top             =   930
         Width           =   1095
      End
      Begin SSCommand biCat
         Caption         =   "&CatStr"
         Font3D          =   1  'Raised w/light shading
         Height          =   900
         Left            =   30
         Picture         =   STRDLLAP.FRX:2E68
         RoundedCorners  =   0   'False
         TabIndex        =   4
         Top             =   930
         Width           =   1095
      End
      Begin SSCommand biCopy
         Caption         =   "C&opyFile"
         Font3D          =   1  'Raised w/light shading
         Height          =   885
         Left            =   1140
         Picture         =   STRDLLAP.FRX:316A
         RoundedCorners  =   0   'False
         TabIndex        =   3
         Top             =   30
         Width           =   1095
      End
      Begin SSCommand biFind
         Caption         =   "&FindString"
         Font3D          =   1  'Raised w/light shading
         Height          =   885
         Left            =   30
         Picture         =   STRDLLAP.FRX:346C
         RoundedCorners  =   0   'False
         TabIndex        =   2
         Tag             =   "OL"
         Top             =   30
         Width           =   1095
      End
   End
   Begin Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "ArrayStr Demonstration List Box"
      ForeColor       =   &H00800000&
      Height          =   195
      Left            =   5520
      TabIndex        =   9
      Top             =   30
      Width           =   2700
   End
End
Option Explicit

Sub ArrayExample ()
'
' Demonstration example of ArrayStr usage
'
 Dim SHandle As Integer ' ArrayStr object handle
 Dim ii      As Long    ' iterator
 Dim rc      As Long    ' return code

    ' create the sample array string

    SHandle = CreateNewStringArray(1, 1024)

    '
    ' If successful, then away we go
    '

    If SHandle > -1 Then


        '
        '  We'll start by filling the ArrayStr in Serial Mode
        '
        For ii = 0 To 9

            ' put the string NEXT in the list

            rc = PutArrayNext(SHandle, " Originally at line " & ii + 1)

            If rc < 0 Then

                MsgBox "ArrayStr Overflow! Unable to continue.", 48, "PutArrayNext Error"
                DestroyStringArray SHandle

                Exit Sub

            End If

        Next

        ' now insert a string at index #3

        rc = InsertArrayStr(SHandle, 3, "!! Inserted at line 4")

        ' now delete the last string

        rc = DeleteArrayStr(SHandle, 9)

        ' replace the entry #7 with a message using Random Access

        rc = PutArrayStr(SHandle, 7, "!! Changed line 8 with PutArrayStr")

        ' place a note in the last entry that it was deleted

        rc = PutArrayStr(SHandle, 9, "!! Entry deleted by DeleteArrayStr")

        ' reset the current line pointer to the first entry

        ArrayStrSetCLP SHandle, 0


        ' using Serial Mode, fill the demonstration list box

        List.Visible = False
        For ii = 1 To 10

            List.AddItem Format$(ii, "00") & GetArrayNext(SHandle)

        Next
        List.Visible = True

        'rc = ArrayStrResize(SHandle, 20)
        'MsgBox "(" & rc & ") " & GetArrayStr(SHandle, 1) & " [" & ArrayStrElements(SHandle) & "]"


        ' ALWAYS REMEMBER TO DESTROY THE ARRAYSTR WHEN FINISHED

        DestroyStringArray SHandle

    Else

        MsgBox "Not enough memory to create the ArrayStr Object!", 48, "ArrayStr Create Error"

    End If

End Sub

Sub biArray_Click ()
Dim CHandle As Integer
Dim rc As Integer

    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)

    LocateCode "Sub Array" & "Example", "End Sub" & Chr$(13)

    ArrayExample

    CHandle = CreateNewCatString(4096)

    rc = CatStrAddLine(CHandle, "Examine the Code in the Code Window below.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "Then examine the contents of the ListBox.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "The ListBox demonstrates the result of the example code.")

    HintMsg CHandle, "ArrayStr Example Code"

    DestroyCatString CHandle

End Sub

Sub biCat_Click ()
 Dim rc      As Integer
 Dim CHandle As Integer

    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)

    On Error Resume Next

    List.Clear
    Kill "CatStr.Txt"
    CHandle = CreateNewCatString(4096)

    Monitor = ""
    LocateCode "Sub Cat" & "Example", "End Sub" & Chr$(13)

    rc = CatStrAddLine(CHandle, "What follows is a demonstration of CatStr vs VB String concatenation times for a 32k string. Only 32k strings are demonstrated because VB can not handle larger strings.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "When the demonstration is complete, take a look at the code below to see how it works.")

    HintMsg CHandle, "CatStr Example Code"
    DoEvents

    CatExample
    DestroyCatString CHandle

End Sub

'
' Note: The use of CatStrAddLine in this sub is purely
'       for demonstration purposes.
'
Sub biCopy_Click ()
Dim CHandle As Integer
Dim rc As Integer

    CopyExample

    CHandle = CreateNewCatString(4096)

    rc = CatStrAddLine(CHandle, "Examine the Code in the Code Window below.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "The Code in the Code Window demonstrates how to use the CopyFile function.")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "The new file is located in the same directory.")

    HintMsg CHandle, "CopyFile Example Code"

    DestroyCatString CHandle

    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)

    LocateCode "Sub Copy" & "Example", "End Sub" & Chr$(13)

End Sub

'
' Example use of the FindString() and CatStr Objects
'
Sub biFind_Click ()
Dim CHandle As Integer
Dim rc As Integer

    CHandle = CreateNewCatString(4096)

    rc = CatStrAddLine(CHandle, "You are about to see a demonstration of how FindString performs against InStr.  FindString works best with large strings and medium size targets (more than 3 characters).")
    rc = CatStrAddLine(CHandle, "")
    rc = CatStrAddLine(CHandle, "After the dialog boxes have shown you how it performs, check out the code in the code window.")

    HintMsg CHandle, "FindString vs InStr Example Code"
    DoEvents

    DestroyCatString CHandle

    ' This call is used to display the demonstration
    ' code for the program.  Please don't look behind
    ' that curtain. (The Wizard of OZ)

    FindExample
    LocateCode "Sub Find" & "Example", "End Sub" & Chr$(13)

End Sub

Sub biQuit_Click ()

    Unload Me

End Sub

'
' Demonstration of how CatStr out performs VB Strings
' in concatenation speed.
'
Sub CatExample ()

 Dim CHandle As Integer ' CatStr Object Handle
 Dim rc      As Integer ' return code
 Dim Temp    As String  ' temp string variable for save
 Dim t                  ' timer accumulator
 Dim VBTime

    On Error Resume Next

    ' create the maximum CatStr Object

    CHandle = CreateNewCatString(32768)

    ' Fail if not enough memory

    If CHandle < 0 Then

        MsgBox "Unable to allocate 32k for CatStr!", 48, "CatStr Create Error"
        Exit Sub

    End If


    ' Use 'On Error Goto' to trap when string is full
    '
    ' NOTE: This is the fastest way to do this and simulates
    '       CatStr objects more fairly than determining the
    '       length of the string with Len().


' ****************** Visual Basic String Test ************************

    On Error GoTo VBStrFull

    Temp$ = ""

    Screen.MousePointer = 11
    t = Timer
    While True

        Temp$ = Temp$ & "This is a sample line of text."

    Wend

VBStrFull:

    t = Timer - t
    Screen.MousePointer = 0

    On Error Resume Next
    VBTime = t

    MsgBox "Concatenating a " & Len(Temp$) & " character Visual Basic String took " & Format$(t, "Standard") & " seconds."


' ******************** CatStr String Test ****************************

    rc = 0

    Screen.MousePointer = 11
    t = Timer
    While rc = 0

        rc = CatStrAddLine(CHandle, "This is a sample line of text.")

    Wend
    t = Timer - t
    Screen.MousePointer = 0

    MsgBox "Concatenating a " & CatStrLength(CHandle) & " character CatStr took " & Format$(t, "Standard") & " seconds."


' ************************* Results **********************************

    If t < VBTime Then

        MsgBox "CatStr was " & Format$(VBTime / t, "Standard") & " times faster that VB!"

    Else

        MsgBox "VB was " & Format$(t / VBTime, "Standard") & " times faster that CatStr!"

    End If


    ' ALWAYS REMEMBER TO DESTROY THE OBJECT WHEN FINISHED!

    DestroyCatString CHandle

End Sub

Sub CenterForm (TheForm As Form, OffsetLeft As Integer, OffsetTop As Integer)
Dim FLeft As Integer
Dim FTop As Integer

    If TheForm.WindowState <> 0 Then Exit Sub

    FLeft = ((Screen.Width - TheForm.Width) \ 2) + OffsetLeft
    FTop = (((Screen.Height - TheForm.Height) \ 2) + OffsetTop) * .85

    If TheForm.Left = FLeft And TheForm.Top = FTop Then Exit Sub

    TheForm.Move FLeft, FTop

End Sub

Sub CopyExample ()
Dim rc As Integer

    rc = CopyFile("STRDLLAP.FRM", "COPYFILE.TXT")

    If rc < 0 Then MsgBox "CopyFile Function failed!", 48, "CopyFile Error #" & rc

End Sub

Sub FindExample ()
'
'  Sample of FindString usage
'
'  Many thanks to Jim Moran at Honeywell for the challenge of
'  this example!
'
'  Don't forget to check out CatStrFind() in the help file!
'
 Dim SrcString    As String
 Dim TargetString As String
 Dim locn         As Long
 Dim InStrTime
 Dim FindStringTime
 Dim ii           As Integer


    SrcString = String$(32000, "A") + "BBB"
    TargetString = "AAAAAAAAAAAABBB"

    ' first show how InStr performs

    Screen.MousePointer = 11
    InStrTime = Timer
    For ii = 1 To 10

        locn = InStr(1, SrcString, TargetString)

    Next
    InStrTime = Timer - InStrTime
    Screen.MousePointer = 0

    MsgBox "(Found At " & locn & ") InStr took " & Format$(InStrTime / 10, "###.###0") & " seconds."

    ' now show how FindString performs

    Screen.MousePointer = 11
    FindStringTime = Timer
    For ii = 1 To 10

        locn = FindString(1, SrcString, TargetString)

    Next
    FindStringTime = Timer - FindStringTime
    Screen.MousePointer = 0

    MsgBox "(Found At " & locn & ") FindString took " & Format$(FindStringTime / 10, "###.###0") & " seconds."

    If FindStringTime < InStrTime Then

        MsgBox "FindString was " & Format$(InStrTime / FindStringTime, "###.###0") & " times faster."

    Else

        MsgBox "InStr was " & Format$(FindStringTime / InStrTime, "###.###0") & " times faster."

    End If

End Sub

Sub Form_Load ()

    On Error Resume Next

    CenterForm Me, 0, 0
    ChDir App.Path

    Me.Top = Screen.Height * .05
    Me.Height = Screen.Height * .9
    Me.Left = Screen.Width * .05
    Me.Width = Screen.Width * .9

    Me.Show

End Sub

Sub Form_Paint ()

    Outlines Me

End Sub

Sub Form_Resize ()

    On Error Resume Next

    Monitor.Top = ToolBar.Height + 120
    Monitor.Left = 120
    Monitor.Width = ScaleWidth - 240
    Monitor.Height = ScaleHeight - ToolBar.Height - 240
    List.Width = ScaleWidth - List.Left - 120

End Sub

'
' This subroutine demonstrates how CatStr (and ArrayStr) Objects
' can be passed to other functions using only the handle.
'
Sub HintMsg (CHandle As Integer, Title As String)

    HintDialog.Caption = Title
    HintDialog.Hint = CatStrCopy(CHandle)
    HintDialog.Show 1

End Sub

Sub LocateCode (Head As String, Tail As String)
'
' This subroutine is used by the demonstration program to
' read the form file, locate the desired subroutine (beginning and
' end) and then highlight the text.
'
' It also serves as an example of the FindStringIC function.
'

 Dim File    As Integer  ' file handle to load STRDLLAP.FRM
 Dim Buf     As String   ' line buffer
 Dim CHandle As Integer  ' CatStr Object handle
 Dim rc      As Integer  ' return code
 Dim Looping As Integer  ' looping switch while reading file
 Dim locn    As Long     ' location pointer for FindStringIC
 Dim length  As Long     ' calculated length of located text

    ' locate a free file handle

    MousePointer = 11
    List.Clear
    Monitor.Visible = False
    Monitor = ""

    File = FreeFile

    ' create a new CatStr object

    CHandle = CreateNewCatString(32768)

    ' open and read the file

    Open "STRDLLAPP.FRM" For Input As #File

    Looping = True
    While Not EOF(File) And Looping

        Line Input #File, Buf

        ' use the CatStr object to buffer the
        ' lines read from the file

        rc = CatStrAddLine(CHandle, Buf)

        '
        ' stop if no more room in the buffer
        '
        If rc < 0 Then ' can't read any more
            Looping = False
        End If

    Wend

    Close #File

    '
    ' search for the subroutine declaration
    '
    locn = CatStrFind(CHandle, 1, Head)

    '
    ' As long as you haven't fiddled with the code
    ' this should work
    '
    If locn > 0 Then

        length = CatStrFind(CHandle, locn, Tail) - locn + Len(Tail) - 1
        Monitor = CatStrMid$(CHandle, locn, length)

    Else

        MsgBox "This example requires an un-modified version of STRDLLAPP.FRM", 48, "Demo Error"

    End If

    '
    ' ALWAYS REMEMBER TO DESTROY THE OBJECT WHEN FINISHED
    '

    DestroyCatString CHandle

    MousePointer = 0
    Monitor.Visible = True
    Monitor.SetFocus

End Sub

Sub Monitor_KeyPress (KeyAscii As Integer)

    KeyAscii = 0

End Sub

Sub Outlines (FormName As Form)

Dim drkgray     As Long
Dim fullwhite   As Long
Dim i           As Integer
Dim ctop        As Integer
Dim cleft       As Integer
Dim cright      As Integer
Dim cbottom     As Integer
Dim Offset      As Integer

    On Error Resume Next

    Dim cName As Control
    Offset = 0

    FormName.Cls

    drkgray = RGB(128, 128, 128)
    fullwhite = RGB(255, 255, 255)

    For i = 0 To (FormName.Controls.Count - 1)

        Set cName = FormName.Controls(i)

        If TypeOf cName Is Menu Then

            GoTo SkipThisControl

        End If


        If (UCase(cName.Tag) = "OL") Then

            ctop = cName.Top - Screen.TwipsPerPixelY
            cleft = cName.Left - Screen.TwipsPerPixelX
            cright = cName.Left + cName.Width + (Screen.TwipsPerPixelX * Offset)
            cbottom = cName.Top + cName.Height + (Screen.TwipsPerPixelY * Offset)

            FormName.Line (cleft, ctop)-(cright, ctop), drkgray
            FormName.Line (cleft, ctop)-(cleft, cbottom), drkgray
            FormName.Line (cleft, cbottom)-(cright, cbottom), fullwhite
            FormName.Line (cright, ctop)-(cright, cbottom), fullwhite

        End If

SkipThisControl:

    Next i

End Sub

Sub ToolBar_Click ()

    Outlines Me

End Sub