PC World Komputer 1998 November/pcwk_11_98a.iso/Wtestowe/SOFTSRC/vtrial15.exe/DATA.1/NewLT.frm

Text File | 1997-03-20 | 18KB | 645 lines

VERSION 4.00
Begin VB.Form NewLineType
   Caption         =   "Create a New Linetype"
   ClientHeight    =   4335
   ClientLeft      =   750
   ClientTop       =   4890
   ClientWidth     =   5520
   Height          =   4740
   Left            =   690
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   ScaleHeight     =   4335
   ScaleWidth      =   5520
   ShowInTaskbar   =   0   'False
   Top             =   4545
   WhatsThisButton =   -1  'True
   WhatsThisHelp   =   -1  'True
   Width           =   5640
   Begin VB.CommandButton CopyCmd
      Caption         =   "Copy"
      Height          =   375
      Left            =   240
      TabIndex        =   10
      Top             =   2760
      Width           =   735
   End
   Begin VB.CommandButton DelCmd
      Caption         =   "Delete"
      Height          =   375
      Left            =   240
      TabIndex        =   9
      Top             =   2280
      Width           =   735
   End
   Begin VB.CommandButton DnCmd
      Caption         =   "Mv Dn"
      Height          =   375
      Left            =   240
      TabIndex        =   8
      Top             =   1800
      Width           =   735
   End
   Begin VB.CommandButton UpCmd
      Caption         =   "Mv Up"
      Height          =   375
      Left            =   240
      TabIndex        =   7
      Top             =   1320
      Width           =   735
   End
   Begin VB.TextBox SpaceLength
      Height          =   375
      Left            =   4440
      TabIndex        =   5
      Text            =   "SpaceLength"
      Top             =   1920
      Width           =   855
   End
   Begin VB.TextBox DashLength
      Height          =   375
      Left            =   4440
      TabIndex        =   3
      Text            =   "DashLength"
      Top             =   1440
      Width           =   855
   End
   Begin VB.CommandButton DotCmd
      Caption         =   "Do&t"
      Height          =   375
      Left            =   3360
      TabIndex        =   6
      Top             =   2400
      Width           =   975
   End
   Begin VB.CommandButton SpaceCmd
      Caption         =   "&Space"
      Height          =   375
      Left            =   3360
      TabIndex        =   4
      Top             =   1920
      Width           =   975
   End
   Begin VB.CommandButton DashCmd
      Caption         =   "&Dash"
      Height          =   375
      Left            =   3360
      TabIndex        =   2
      Top             =   1440
      Width           =   975
   End
   Begin VB.CommandButton HelpCmd
      Caption         =   "&Help"
      Height          =   375
      Left            =   3840
      TabIndex        =   15
      Top             =   3840
      Width           =   1455
   End
   Begin VB.CommandButton CancelCmd
      Caption         =   "Cancel"
      Height          =   375
      Left            =   2040
      TabIndex        =   14
      Top             =   3840
      Width           =   1455
   End
   Begin VB.ListBox NewLinePieces
      Height          =   1785
      Left            =   1200
      TabIndex        =   11
      Top             =   1320
      Width           =   1815
   End
   Begin VB.TextBox LineTypeDesc
      Height          =   375
      Left            =   1440
      TabIndex        =   1
      Top             =   720
      Width           =   3975
   End
   Begin VB.TextBox LineTypeName
      Height          =   375
      Left            =   1440
      TabIndex        =   0
      Top             =   120
      Width           =   3975
   End
   Begin VB.PictureBox NewLineSample
      BackColor       =   &H00000000&
      Height          =   255
      Left            =   120
      ScaleHeight     =   225
      ScaleWidth      =   5265
      TabIndex        =   12
      Top             =   3360
      Width           =   5295
   End
   Begin VB.CommandButton DoneCmd
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   375
      Left            =   240
      TabIndex        =   13
      Top             =   3840
      Width           =   1455
   End
   Begin VB.Label Label2
      Caption         =   "Description"
      Height          =   255
      Left            =   120
      TabIndex        =   17
      Top             =   840
      Width           =   1215
   End
   Begin VB.Label Label1
      Caption         =   "Linetype Name"
      Height          =   255
      Left            =   120
      TabIndex        =   16
      Top             =   240
      Width           =   1215
   End
End
Attribute VB_Name = "NewLineType"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Public ltDirtyFlag%

Sub AddPiece(Piece As Single)
'
'   adds a new piece to the pieces list,
'   it takes a value and translates it into an english string
'
'   There's some hokey code here (the Piece * 10000) below.  This is
'   to store a floating point number in a long integer space.  This
'   cuts off any data past four decimals, and looses any data greater
'   than 200,000 (approximately).  Seems a likely risk.
'
'   Proper method would be to use the item data field instead as an
'   index in to an array of doubles.
'

    If (Piece = 0) Then
        NewLinePieces.AddItem "Dot"
        NewLinePieces.ItemData(NewLinePieces.NewIndex) = 0
    End If
    If (Piece < 0) Then
        NewLinePieces.AddItem "Space " & Str$(Piece) & " Units"
        NewLinePieces.ItemData(NewLinePieces.NewIndex) = Piece * 10000
    End If
    If (Piece > 0) Then
        NewLinePieces.AddItem "Dash " & Str$(Piece) & " Units"
        NewLinePieces.ItemData(NewLinePieces.NewIndex) = Piece * 10000
    End If
End Sub

Sub DoButtons()
'
'   activate or deactive list editing buttons as needed
'
    If (NewLinePieces.ListCount > 0) Then
        UpCmd.Enabled = True
        DnCmd.Enabled = True
        DelCmd.Enabled = True
        If (NewLinePieces.ListIndex <> -1) Then
            CopyCmd.Enabled = True
        Else
            CopyCmd.Enabled = False
        End If
    Else
        UpCmd.Enabled = False
        DnCmd.Enabled = False
        DelCmd.Enabled = False
        CopyCmd.Enabled = False
    End If
End Sub

Sub DoSample()
'
'   make the sample line type
'
    Dim MaxX, Y, X1, X2, SF, Cntr As Integer
    Dim ptr%, ptr2%                              ' used in parsing the spec string
    Dim lng#
    Dim LT$

'
'   if there's nothing to display, then clear the sample and end
    If (NewLinePieces.ListCount = 0) Then
        NewLineSample.Cls
        GoTo DoSample_Exit
    End If


'
'   draw a sample of the line
    MaxX = NewLineSample.Width                   ' run the line sample the full width
    Y = (NewLineSample.Height / 2) - 20          ' run the line across the center of the box

    X1 = 0
    X2 = 0
    SF = MaxX / 8                                ' sort of a scale factor
    NewLineSample.Cls                            ' clear the sample box
    Cntr = 0                                     ' for determing how often to call DoEvents()

'
'   put together the description string
    For ptr% = 0 To NewLinePieces.ListCount - 1
        LT$ = LT$ + Str$(NewLinePieces.ItemData(ptr%) / 10000) & ","
    Next
    If (Right$(LT$, 1) = ",") Then
        LT$ = Left$(LT$, Len(LT$) - 1)
    End If

    ptr% = 1
    ptr2% = 1


'
'   get total length of one iteration of line, so that it may be
'   scaled accordingly for the sample window
    Dim LenIter As Single
Loup:
    ptr2% = InStr(ptr%, LT$, ",")
    If (ptr2% <> 0) Then
        LenIter = LenIter + Abs(Val(Mid$(LT$, ptr%, ptr2%)))
        ptr% = ptr2% + 1
        GoTo Loup
    Else
        LenIter = LenIter + Abs(Val(Mid$(LT$, ptr%)))
    End If

'
'   is this right?  What about a line spec that is just DOT ?
    If (LenIter = 0) Then
        NewLineSample.Cls
        GoTo DoSample_Exit
    End If

    Debug.Print "Iteration length = " & Str$(LenIter)
    If (MaxX / (LenIter * SF)) < 4 Then
    '
    '   arbitrarily scale it so that we get at least 4 iterations
        SF = SF * (1 / LenIter)
        Debug.Print "Rescaled: SF = " & Str$(SF)
    End If


    ptr% = 1
    ptr2% = 1
    While X2 < NewLineSample.Width
        Cntr = Cntr + 1                          ' allows other processing to procede while line is being drawn
        If Cntr Mod 10 = 0 Then
            DoEvents
        End If

    '
    '   parse the spec string to get the next piece to be drawn
        ptr2% = InStr(ptr%, LT$, ",")
        If (ptr2% <> 0) Then
            lng# = Val(Mid$(LT$, ptr%, ptr2%))
            ptr% = ptr2% + 1
        Else
            lng# = Val(Mid$(LT$, ptr%))
            ptr% = 1
        End If

    '
    '   draw the segment
        X1 = X2
        If (lng# < 0) Then                      ' space
            X2 = X1 + Abs((lng# * SF))
        Else
            If (lng# = 0) Then                  ' dot
                X2 = X1 + 2 * Screen.TwipsPerPixelX ' dot has no intrinsic length of its own
            Else                                ' dash
                X2 = X1 + (lng# * SF)
            End If
            NewLineSample.Line (X1, Y)-(X2, Y), QBColor(14), BF
        End If
     '  Debug.Print "(X1, Y1)-(X2, Y2) = (" & Str$(X1) & "," & Str$(Y) & ")-(" & Str$(X2) & "," & Str$(Y) & ")"
    Wend

DoSample_Exit:
End Sub


Private Sub CancelCmd_Click()
'
'   quit without saving
'
    Covered = False
    Unload NewLineType
End Sub

Private Sub CopyCmd_Click()
'
'   copy currently highlighted item, and
'   insert it in the space following current item
'
    Dim Idx%
    Idx% = NewLinePieces.ListIndex

    If (Idx% <> -1) Then
        Dim t$, l&
        t$ = NewLinePieces.List(Idx%)
        l& = NewLinePieces.ItemData(Idx%)

        Idx% = Idx% + 1

        NewLinePieces.AddItem t$, Idx%
        NewLinePieces.ItemData(Idx%) = l&
        NewLinePieces.ListIndex = Idx%

        DoSample
        DoButtons
    End If
End Sub

Private Sub DashCmd_Click()
'
'   add a dash of the given length to the pieces
'
    If (Val(DashLength.Text) = 0) Then
        Beep
        MsgBox "Invalid length for Dash"
    Else
        AddPiece Val(DashLength.Text)            ' add the new token to the list
        DoSample                                 ' refresh the line sample
        DoButtons
    End If
End Sub

Private Sub DelCmd_Click()
'
'   remove hightlighted item from list
'
    Dim Idx%
    Idx% = NewLinePieces.ListIndex

    If (Idx% <> -1) Then
        NewLinePieces.RemoveItem Idx%
        DoSample
        If (Idx% < NewLinePieces.ListCount) Then
            NewLinePieces.ListIndex = Idx%
        End If
        DoButtons
    End If
End Sub

Private Sub DnCmd_Click()
'
'   move highlighted item up one in list
'
    Dim i As Integer
    If (NewLinePieces.ListIndex <> -1) Then
        i = NewLinePieces.ListIndex
        If (i < NewLinePieces.ListCount - 1) Then
            Dim t$, l&
            t$ = NewLinePieces.List(i)
            l& = NewLinePieces.ItemData(i)
            NewLinePieces.RemoveItem (i)

            NewLinePieces.AddItem t$, i + 1
            NewLinePieces.ItemData(i + 1) = l&
            NewLinePieces.ListIndex = i + 1

            DoSample
            DoButtons
        End If
    End If
End Sub

Private Sub DoneCmd_Click()
'
'   done with new line type

'   if there are no specs entered, then just exit without saving
    If (NewLinePieces.ListCount = 0) Then GoTo DoneCmd_Quit

'   there are pieces, be sure there is a name for the line type
    If (LineTypeName.Text = "") Then
        Beep
        LineTypeName.SetFocus
        GoTo DoneCmd_Exit
    End If

'
'   put together the specification string
    Dim ptr%, LT$
    For ptr% = 0 To NewLinePieces.ListCount - 1
        LT$ = LT$ + Str$(NewLinePieces.ItemData(ptr%) / 10000) & ","
    Next
    If (Right$(LT$, 1) = ",") Then
        LT$ = Left$(LT$, Len(LT$) - 1)
    End If

    Dim D$, aIdx%, sIdx%
    D$ = LineTypeName.Text
    If (gblMode = 0) Then
    '
    '   stuff the information on the main form
        Form1.AcadLineList.AddItem D$
        aIdx% = Form1.AcadLineList.NewIndex
        Form1.AcadLineSpecs.AddItem LT$
        sIdx% = Form1.AcadLineSpecs.NewIndex
        Form1.AcadLineList.ItemData(aIdx%) = sIdx%
        Form1.AcadLineSpecs.ItemData(sIdx%) = aIdx%

        Form1.AcadLineList.ListIndex = aIdx%    ' hightlight the new line
    Else
    '
    '   stuff modified information back into the same slot
        Form1.AcadLineList.List(gblLineIdx) = D$
        sIdx% = Form1.AcadLineList.ItemData(gblLineIdx)
        Form1.AcadLineSpecs.List(sIdx%) = LT$
    End If

DoneCmd_Quit:
    Covered = False
    Unload NewLineType

DoneCmd_Exit:
End Sub


Private Sub DotCmd_Click()
'
'   add a dot to the pieces
'
    AddPiece 0                              ' add the new token to the list
    DoSample                                ' refresh the line sample
    DoButtons
End Sub

Private Sub Form_Load()
'
'   start of NewLineType form
'
'   If gblMode = 0 then this form is to create a new linetype
'   If gblMode = 1 then this form is to edit an existing linetype
'
    WindowOnTop hWnd

    Covered = True
    NewLineType.Top = ((Screen.Height - NewLineType.Height) / 2)
    NewLineType.Left = ((Screen.Width - NewLineType.Width) / 2)

'
'   default values for edit boxes, etc
    DashLength.Text = "0.25"
    SpaceLength.Text = "0.25"
    NewLinePieces.Clear
    LineTypeName.Text = ""
    LineTypeDesc.Text = ""
    NewLineSample.Cls               ' clear the sample window

    If (gblMode = 0) Then
        NewLineType.Caption = "Create a New Linetype"
        UpCmd.Enabled = False
        DnCmd.Enabled = False
        DelCmd.Enabled = False
        CopyCmd.Enabled = False
    End If

    If (gblMode = 1) Then
        NewLineType.Caption = "Edit Existing Linetype"
        LineTypeName.Text = gblLTName
        LineTypeDesc.Text = gblLTDesc

        Dim ptr1%, ptr2%, p$
        ptr1% = 1
        ptr2% = 1
        Debug.Print "gblLTSpec = " & gblLTSpec
Loupy:
        ptr1% = InStr(ptr2%, gblLTSpec, ",")
        If (ptr1% <> 0) Then
            p$ = Mid$(gblLTSpec, ptr2%, ptr1% - ptr2%)
        Else
            p$ = Mid$(gblLTSpec, ptr2%)
        End If

        If Val(p$) = 0 Then
            NewLinePieces.AddItem "Dot"
            NewLinePieces.ItemData(NewLinePieces.NewIndex) = 0
        End If
        If Val(p$) < 0 Then
            NewLinePieces.AddItem "Space " & Abs(Val(p$)) & " Units"
            NewLinePieces.ItemData(NewLinePieces.NewIndex) = Val(p$) * 10000
        End If
        If Val(p$) > 0 Then
            NewLinePieces.AddItem "Dash " & Val(p$) & " Units"
            NewLinePieces.ItemData(NewLinePieces.NewIndex) = Val(p$) * 10000
        End If
        If (ptr1% <> 0) Then
            ptr2% = ptr1% + 1
            GoTo Loupy
        End If



        DoSample
    End If

    ltDirtyFlag% = False

End Sub


Private Sub Form_Paint()
    DoSample
End Sub


Private Sub NewLinePieces_Click()
'
'   user clicked on an item in the list
'



'
'   there will probably be an item hightlighted now.
'   activate or not the copy button accordingly.
    If (NewLinePieces.ListIndex <> -1) Then
        CopyCmd.Enabled = True
    Else
        CopyCmd.Enabled = False
    End If

End Sub

Private Sub NewLinePieces_DblClick()
'
'   if user double clicks on an item, then allow him to edit it
'
    Dim Idx%
    Idx% = NewLinePieces.ListIndex
    If (Idx% <> -1) Then
        gblEditValue = Val(NewLinePieces.ItemData(NewLinePieces.ListIndex) / 10000)
        EditPiece.Show 1

        NewLinePieces.RemoveItem Idx%
'       NewLinePieces.AddItem Str$(gblEditValue), Idx%

        If (gblEditValue = 0) Then
            NewLinePieces.AddItem "Dot", Idx%
            NewLinePieces.ItemData(NewLinePieces.NewIndex) = 0
        End If
        If (gblEditValue < 0) Then
            NewLinePieces.AddItem "Space " & Str$(gblEditValue) & " Units", Idx%
            NewLinePieces.ItemData(NewLinePieces.NewIndex) = gblEditValue * 10000
        End If
        If (gblEditValue > 0) Then
            NewLinePieces.AddItem "Dash " & Str$(gblEditValue) & " Units", Idx%
            NewLinePieces.ItemData(NewLinePieces.NewIndex) = gblEditValue * 10000
        End If

        DoSample
    End If
End Sub


Private Sub SpaceCmd_Click()
'
'   add a space of the given length to the pieces
'
    If (Val(SpaceLength.Text) = 0) Then
        Beep
        MsgBox "Invalid length for Space"
    Else
        AddPiece -1 * Abs(Val(SpaceLength.Text))     ' add the new token to the list
        DoSample                                     ' refresh the line sample
        DoButtons
    End If
End Sub


Private Sub UpCmd_Click()
'
'   move highlighted item up one in list
'
    Dim i As Integer
    If (NewLinePieces.ListIndex <> -1) Then
        i = NewLinePieces.ListIndex
        If (i <> 0) Then
            Dim t$, l&
            t$ = NewLinePieces.List(i)
            l& = NewLinePieces.ItemData(i)
            NewLinePieces.RemoveItem (i)

            NewLinePieces.AddItem t$, i - 1
            NewLinePieces.ItemData(i - 1) = l&
            NewLinePieces.ListIndex = i - 1

            DoSample
            DoButtons
        End If
    End If
End Sub