Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/dump_s1r/docwadpr.dob

Text File | 1998-12-27 | 14.4 KB | 471 lines

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.UserDocument  docWadProp
   AutoRedraw      =   -1  'True
   ClientHeight    =   4908
   ClientLeft      =   48
   ClientTop       =   48
   ClientWidth     =   7812
   LockControls    =   -1  'True
   Palette         =   "WadProp.frx":000C
   PaletteMode     =   2  'Custom
   ScaleHeight     =   4908
   ScaleWidth      =   7812
   Begin VB.CommandButton cmdLoadExternaL
      Caption         =   "Load ExternaL"
      Height          =   345
      Left            =   3720
      TabIndex        =   22
      Top             =   270
      Width           =   1275
   End

   Begin VB.CommandButton cmdNew
      Caption         =   "New..."
      Height          =   345
      Left            =   2400
      TabIndex        =   17
      Top             =   270
      Width           =   1275
   End

   Begin MSComDlg.CommonDialog c
      Left            =   2580
      Top             =   2220
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   327681
      CancelError     =   -1  'True
      Filter          =   "LMP Files(*.lmp)|*.lmp"
   End

   Begin VB.ComboBox cboWads
      Height          =   315
      Left            =   60
      Style           =   2  'Dropdown List
      TabIndex        =   8
      Top             =   270
      Width           =   2310
   End

   Begin VB.Frame fmWadProp
      Caption         =   "Selected Wads Properties"
      Height          =   3795
      Left            =   0
      TabIndex        =   1
      Top             =   660
      Width           =   7755

      Begin VB.CommandButton Command1
         Caption         =   "Export +"
         Height          =   315
         Left            =   6720
         TabIndex        =   19
         Top             =   420
         Width           =   945
      End

      Begin VB.CommandButton cmdSaveAs
         Caption         =   "Save &As"
         Height          =   315
         Left            =   5730
         TabIndex        =   16
         Top             =   420
         Width           =   945
      End

      Begin VB.CommandButton cmdUpdate
         Caption         =   "&Save"
         Default         =   -1  'True
         Height          =   315
         Left            =   4740
         TabIndex        =   15
         Top             =   420
         Width           =   945
      End

      Begin VB.CommandButton cmdExport
         Caption         =   "Export"
         Height          =   315
         Left            =   3750
         TabIndex        =   14
         Top             =   420
         Width           =   945
      End

      Begin VB.CommandButton cmdAddEnt
         Caption         =   "Add Entry"
         Height          =   315
         Left            =   2760
         TabIndex        =   11
         Top             =   420
         Width           =   945
      End

      Begin VB.CommandButton cmdDelEnt
         Caption         =   "Delete"
         Height          =   315
         Left            =   1770
         TabIndex        =   10
         Top             =   420
         Width           =   945
      End

      Begin VB.Frame fmEntProp
         Caption         =   "Entry Properties"
         Height          =   2955
         Left            =   60
         TabIndex        =   4
         Top             =   780
         Width           =   7605

         Begin VB.CommandButton Command2
            Caption         =   "Re-Calc"
            Height          =   315
            Left            =   5250
            TabIndex        =   23
            Top             =   450
            Width           =   945
         End

         Begin VB.TextBox Text1
            Height          =   315
            Left            =   3540
            MaxLength       =   4
            TabIndex        =   21
            Text            =   "PWAD"
            Top             =   450
            Width           =   1635
         End

         Begin VB.ComboBox cboEntryType
            Height          =   315
            ItemData        =   "WadProp.frx":0052
            Left            =   1740
            List            =   "WadProp.frx":0089
            Locked          =   -1  'True
            Style           =   2  'Dropdown List
            TabIndex        =   13
            Top             =   450
            Width           =   1755
         End

         Begin VB.TextBox txtEByts
            Appearance      =   0  'Flat
            BeginProperty Font
               Name            =   "Fixedsys"
               Size            =   10.8
               Charset         =   0
               Weight          =   400
               Underline       =   0   'False
               Italic          =   0   'False
               Strikethrough   =   0   'False
            EndProperty
            Height          =   1365
            Left            =   60
            MultiLine       =   -1  'True
            ScrollBars      =   3  'Both
            TabIndex        =   9
            Text            =   "WadProp.frx":0174
            Top             =   1560
            Width           =   7455
         End

         Begin VB.TextBox txtEName
            Height          =   315
            Left            =   60
            TabIndex        =   5
            Text            =   "Name"
            Top             =   450
            Width           =   1635
         End

         Begin VB.Label Label4
            AutoSize        =   -1  'True
            Caption         =   "Header Text:"
            Height          =   195
            Left            =   3570
            TabIndex        =   20
            Top             =   240
            Width           =   930
         End

         Begin VB.Label Label3
            AutoSize        =   -1  'True
            Caption         =   "Position: 0"
            Height          =   195
            Left            =   60
            TabIndex        =   18
            Top             =   1020
            Width           =   735
         End

         Begin VB.Label lblSize
            AutoSize        =   -1  'True
            Caption         =   "Size: "
            Height          =   195
            Left            =   60
            TabIndex        =   12
            Top             =   780
            Width           =   390
         End

         Begin VB.Label lblEName
            AutoSize        =   -1  'True
            Caption         =   "Entry Name:"
            Height          =   195
            Left            =   60
            TabIndex        =   6
            Top             =   210
            Width           =   870
         End

      End
      Begin VB.ComboBox cboResource
         Height          =   315
         Left            =   60
         Style           =   2  'Dropdown List
         TabIndex        =   3
         Top             =   420
         Width           =   1665
      End

      Begin VB.Label Label1
         AutoSize        =   -1  'True
         Caption         =   "Entries:"
         Height          =   195
         Left            =   60
         TabIndex        =   2
         Top             =   210
         Width           =   525
      End

   End
   Begin VB.CommandButton cmdClose
      Cancel          =   -1  'True
      Caption         =   "&Close"
      Height          =   405
      Left            =   3390
      TabIndex        =   0
      Top             =   4470
      Width           =   1035
   End

   Begin VB.Label Label2
      AutoSize        =   -1  'True
      Caption         =   "Wad List:"
      Height          =   195
      Left            =   90
      TabIndex        =   7
      Top             =   30
      Width           =   675
   End

End
Attribute VB_Name = "docWadProp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Const const_strWadFltr = "Wad Files(*.Wad)|*.Wad"
Private cWad As New clsWad
Private FFiles As New Files
Private Sub cboResource_Click()
    If cboResource.ListIndex = -1 Then Exit Sub
    lblSize.Caption = "Size: " & cWad.ReturnLump(cboResource.ListIndex + 1).LumpSize
    txtEName = cWad.ReturnLump(cboResource.ListIndex + 1).LumpName
    cboEntryType.ListIndex = cWad.ReturnLump(cboResource.ListIndex + 1).LumpType
    Dim bBytes() As Byte
    cWad.ReturnLump(cboResource.ListIndex + 1).LumpBytes bBytes
    If lblSize = "Size: 0" Then _
        txtEByts = "": _
        Label3.Caption = "Position: 0" _
        : Exit Sub
    If UBound(bBytes) >= 3000 Then
        ReDim Preserve bBytes(1 To 3000)
    End If
    Label3.Caption = "Position: " & cWad.ReturnLump(cboResource.ListIndex + 1).LumpPosition
    txtEByts = BytesToText(bBytes)
End Sub

Private Sub cboWads_Click()
    cboResource.Clear
    If cboWads.ListIndex = -1 Then
        Text1.Enabled = False
        Exit Sub
    End If
    Set cWad = New clsWad
    cWad.Load FFiles(cboWads.ListIndex + 1).FileName
    Text1.Enabled = True
    Text1.Text = cWad.WadType
    Update2
End Sub

Private Sub cmdAddEnt_Click()
    Dim m_strEntryName As String, m_msgRet As VbMsgBoxResult, bts() As Byte
    m_strEntryName = InputBox("Enter the Name of the New Entry...", "Define Lump Name", "NewLumpX")
    If m_strEntryName = "" Then _
        Exit Sub
    m_msgRet = MsgBox("Is the Entry in a file?", vbYesNo + vbQuestion, "Query")
    If m_msgRet = vbYes Then
        On Error Resume Next
        c.Filter = "Mus Files (*.mus)|*.mus|ppm [Image] Files (*.ppm)|*.ppm|All Files (*.*)|*.*"
        c.ShowOpen
        If Err <> 0 Then Exit Sub
        If Not FileLen(c.FileName) = 0 Then
            ReDim bts(1 To FileLen(c.FileName))
            Open c.FileName For Binary As #1
            Get #1, 1, bts
            Close #1
                If cWad.Count = 0 Then
                    cWad.AddLump bts, m_strEntryName, 12, UBound(bts)
                    cWad.LumpDirectory.AddEntry m_strEntryName, UBound(bts), 12
                Else
                    cWad.AddLump bts, m_strEntryName, cWad.ReturnLump(cWad.Count).LumpPosition + cWad.ReturnLump(cWad.Count).LumpSize, UBound(bts)
                    cWad.LumpDirectory.AddEntry m_strEntryName, UBound(bts), cWad.ReturnLump(cWad.Count).LumpPosition + cWad.ReturnLump(cWad.Count).LumpSize
                End If
            cWad.ReCalc
            cWad.LumpDirectory.ReCalc
            Update2
            Exit Sub
        End If
    End If
    ReDim bts(0)
    cWad.AddLump bts, m_strEntryName, 0, 0
    cWad.LumpDirectory.AddEntry m_strEntryName, 0, 0
    cWad.ReCalc
    cWad.LumpDirectory.ReCalc
    Update2
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

Public Sub SetUp(Files As Files)
    Set FFiles = Files
    Update1
    Show
End Sub

Public Sub Update1()
    Dim m_lngLoop As Long
    cboWads.Clear
    For m_lngLoop = 1 To FFiles.Count
    cboWads.AddItem FFiles(m_lngLoop).IDName
    Next
    Update2
End Sub

Public Sub Update2()
    Dim m_lngLoop As Long
    If cboWads.ListIndex = -1 Then Exit Sub
    cboResource.Clear
    For m_lngLoop = 1 To cWad.Count
        If InStr(1, cWad.ReturnLump(m_lngLoop).LumpName, Chr(0)) = 0 Then
            cboResource.AddItem cWad.ReturnLump(m_lngLoop).LumpName
        Else
            cboResource.AddItem Mid(cWad.ReturnLump(m_lngLoop).LumpName, 1, InStr(1, cWad.ReturnLump(m_lngLoop).LumpName, Chr(0))) 'cWad.ReturnLump(m_lngLoop).LumpName
        End If
    Next
End Sub

Public Function BytesToText(Text() As Byte) As String
    Dim Buffer As String, id As Integer, m_lngLoop As Long
    For m_lngLoop = 1 To UBound(Text)
        Buffer = Buffer & (Text(m_lngLoop)) & "-"
    If id = 30 Then Buffer = Buffer & vbCrLf: id = 0
        id = id + 1
    Next
    BytesToText = Mid(Buffer, 1, Len(Buffer) - 1)
End Function

Private Sub cmdDelEnt_Click()
    If cboResource.ListIndex = -1 Then Exit Sub
    Dim m_msgRes As VbMsgBoxResult
    m_msgRes = MsgBox("Are you sure you wish to delete this entry?", vbQuestion + vbYesNo, "Query")
    If m_msgRes = vbYes Then
        cWad.DeleteLump cboResource.ListIndex + 1
        Update2
    End If
End Sub

Private Sub cmdExport_Click()
    On Error Resume Next
    Dim Bytes() As Byte
    c.Filter = "LMP Files(*.lmp)|*.lmp"
    c.Flags = cdlOFNCreatePrompt + 4
    c.ShowSave
    If Err = cdlCancel Then Exit Sub
    cWad.ReturnLump(cboResource.ListIndex + 1).LumpBytes Bytes
    Open c.FileName For Binary As #1
        Put #1, 1, Bytes
    Close #1
End Sub

Private Sub cmdLoadExternaL_Click()
    c.Filter = const_strWadFltr
    On Error Resume Next
    c.ShowOpen
    If Err = cdlCancel Then Exit Sub
    FFiles.Add c.FileName, ReturnExtention(c.FileName, False, "\")
    Update1
End Sub

Private Sub cmdNew_Click()
    c.Filter = const_strWadFltr
    Dim m_msgRes As VbMsgBoxResult
    m_msgRes = MsgBox("Do you wish to create a new BLANK Wad file?", vbYesNo + vbQuestion, "Query")
    If Not m_msgRes = vbYes Then
        Exit Sub
    End If
    On Error Resume Next
    c.ShowSave
    If Err <> 0 Then Exit Sub
    On Error GoTo 0
    Set cWad = New clsWad
    cWad.WadDirStart = 12
    cWad.WadType = "PWAD"
    cWad.WadLumpCount = 0
    cWad.Save c.FileName
    FFiles.Add c.FileName, ReturnExtention(c.FileName, False, "\")
    Update1
End Sub

Private Sub cmdSaveAs_Click()
    On Error Resume Next
    Dim Bytes() As Byte
    c.Filter = const_strWadFltr
    c.Flags = cdlOFNCreatePrompt + 4
    c.ShowSave
    If Err = cdlCancel Then Exit Sub
    cWad.Save c.FileName
End Sub

Private Sub cmdUpdate_Click()
    If cboWads.ListIndex = -1 Then Exit Sub
    cWad.Save FFiles(cboWads.ListIndex + 1).FileName
    Update2
End Sub

Private Sub Command2_Click()
    cWad.ReCalc
End Sub


Private Sub Text1_Change()
    Text1 = UCase(Text1)
    If Not (Text1 = "PWAD" Or Text1 = "IWAD") Then
        Text1 = "PWAD"
    End If
    cWad.WadType = Text1
End Sub

Private Sub txtEName_Change()
    If cboResource.ListIndex = -1 Or cboWads.ListIndex = -1 Then Exit Sub
    cWad.ReturnLump(cboResource.ListIndex + 1).LumpName = txtEName
    cWad.LumpDirectory(cboResource.ListIndex + 1).LumpName = txtEName
    cboResource.List(cboResource.ListIndex) = txtEName
End Sub