VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmPakFile 
   Caption         =   "(My Pak File)"
   ClientHeight    =   3180
   ClientLeft      =   60
   ClientTop       =   660
   ClientWidth     =   4680
   Icon            =   "frmPakFile.frx":0000
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3180
   ScaleWidth      =   4680
   WindowState     =   2  'Maximiert
   Begin VB.PictureBox picAssocIcon 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'Kein
      Height          =   240
      Left            =   3960
      ScaleHeight     =   16
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   16
      TabIndex        =   3
      Top             =   120
      Visible         =   0   'False
      Width           =   240
   End
   Begin MSComDlg.CommonDialog cdlFile 
      Left            =   3840
      Top             =   2280
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      Filter          =   "R-PG Pak Files (*.rpak)|*.rpak"
   End
   Begin VB.PictureBox picSizer 
      BackColor       =   &H80000010&
      BorderStyle     =   0  'Kein
      Height          =   2775
      Left            =   1800
      MousePointer    =   9  'Größenänderung W O
      ScaleHeight     =   2775
      ScaleWidth      =   75
      TabIndex        =   2
      Top             =   0
      Width           =   75
      Begin VB.Image imgSize 
         Height          =   195
         Left            =   0
         Picture         =   "frmPakFile.frx":0802
         Stretch         =   -1  'True
         Top             =   0
         Visible         =   0   'False
         Width           =   75
      End
   End
   Begin MSComctlLib.ListView lvw 
      Height          =   2655
      Left            =   2040
      TabIndex        =   1
      Top             =   0
      Width           =   1185
      _ExtentX        =   2090
      _ExtentY        =   4683
      View            =   2
      Arrange         =   1
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      OLEDragMode     =   1
      OLEDropMode     =   1
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      Appearance      =   0
      OLEDragMode     =   1
      OLEDropMode     =   1
      NumItems        =   0
   End
   Begin MSComctlLib.ImageList iml 
      Left            =   3840
      Top             =   1440
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   4
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmPakFile.frx":0914
            Key             =   "dirclosed"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmPakFile.frx":0E66
            Key             =   "diropen"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmPakFile.frx":13B8
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmPakFile.frx":1BCA
            Key             =   "ft_exe"
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.TreeView trv 
      Height          =   2655
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   1815
      _ExtentX        =   3201
      _ExtentY        =   4683
      _Version        =   393217
      HideSelection   =   0   'False
      Indentation     =   0
      Style           =   7
      HotTracking     =   -1  'True
      Appearance      =   0
      OLEDropMode     =   1
   End
   Begin VB.Menu mnuFile 
      Caption         =   "File"
      Begin VB.Menu mnuFileNew 
         Caption         =   "New..."
      End
      Begin VB.Menu mnuFileOpen 
         Caption         =   "Open..."
      End
      Begin VB.Menu mnuFileClose 
         Caption         =   "Close"
      End
      Begin VB.Menu mnuFileDivider4 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFilePassword 
         Caption         =   "Change Archive Password..."
      End
      Begin VB.Menu mnuFileDivider2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileSave 
         Caption         =   "Save"
      End
      Begin VB.Menu mnuFileSaveAs 
         Caption         =   "Save As..."
      End
      Begin VB.Menu mnuFileDivider3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileQuit 
         Caption         =   "Quit"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "?"
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "About..."
      End
   End
   Begin VB.Menu mnuContext 
      Caption         =   "(Context Menus)"
      Begin VB.Menu mnuContextFolder 
         Caption         =   "(Folder Context)"
         Begin VB.Menu mnuContextFolderAdd 
            Caption         =   "Add Folder"
         End
         Begin VB.Menu mnuContextFolderRename 
            Caption         =   "Rename Folder"
         End
         Begin VB.Menu mnuContextFolderDelete 
            Caption         =   "Delete Folder"
         End
      End
      Begin VB.Menu mnuContextFile 
         Caption         =   "(File Context)"
         Begin VB.Menu mnuContextFileView 
            Caption         =   "View Content"
         End
         Begin VB.Menu mnuContextFileExtract 
            Caption         =   "Extract to..."
         End
         Begin VB.Menu mnuContextFileDivider1 
            Caption         =   "-"
         End
         Begin VB.Menu mnuContextFileRename 
            Caption         =   "Rename File"
         End
         Begin VB.Menu mnuContextFileDelete 
            Caption         =   "Delete File"
         End
      End
   End
End
Attribute VB_Name = "frmPakFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public MyPak As cRPakArchive

Public CurrentFolder As cRPakFolder, CurrentPath As String
Dim RootNode As Node

Dim s_x As Long, s_y As Long, Dragging As Boolean

Public PakFileID As Long

Public mCaption As String




Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Const DI_MASK = &H1
Const DI_IMAGE = &H2
Const DI_NORMAL = DI_MASK Or DI_IMAGE

Public Sub UpdateCtls()
mCaption = Mid(MyPak.FileName, InStrRev(MyPak.FileName, "\") + 1) & IIf(MyPak.ChangedFlag, "*", "")
Caption = mCaption

trv.Nodes.Clear
TreeForItem MyPak.Root
RootNode.Bold = True


ListFolder CurrentPath, CurrentFolder
End Sub


Public Sub TreeForItem(Folder As cRPakFolder, Optional ParentNode As Node = Nothing)


Dim n As Node
Set n = trv.Nodes.Add(, , , IIf(Folder.IsRoot, Mid(MyPak.FileName, InStrRev(MyPak.FileName, "\") + 1), Folder.FolderName), IIf(Folder.IsRoot, 3, 1))

If Folder.IsRoot Then Set RootNode = n

n.ExpandedImage = IIf(Folder.IsRoot, 3, 2)

If Not ParentNode Is Nothing Then Set n.Parent = ParentNode

Dim i As Integer
For i = 0 To Folder.FolderCount - 1
    TreeForItem Folder.Folders(i), n
Next i

End Sub

Public Sub ListFolderByPath(Path As String)
Dim f As cRPakFolder
Set f = MyPak.Root.GetFolder(Path)

ListFolder Path, f

End Sub

Public Sub ListFolder(Path As String, Folder As cRPakFolder)
Set CurrentFolder = Folder
CurrentPath = Path

lvw.ListItems.Clear
Dim i As Integer
Dim icn As Integer
Dim ft As String
Dim fn As String

For i = 0 To Folder.FileCount - 1
fn = Folder.FileName(i)
ft = Mid$(fn, InStrRev(fn, ".") + 1)
icn = GetIconForType(ft)
lvw.ListItems.Add , Path & "\" & Folder.FileName(i), Folder.FileName(i), , icn
Next i
End Sub




Private Sub Form_Load()
Set trv.ImageList = iml
Set lvw.Icons = iml
Set lvw.SmallIcons = iml

mnuContext.Visible = False



Set CurrentFolder = MyPak.Root
UpdateCtls

End Sub

Private Sub Form_Resize()
On Error Resume Next
trv.Top = 0
trv.Height = ScaleHeight - trv.Top
lvw.Top = 0
lvw.Left = trv.Width + picSizer.Width
picSizer.Left = trv.Width
picSizer.Height = ScaleHeight
lvw.Width = ScaleWidth - lvw.Left
lvw.Height = ScaleHeight
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim X As VbMsgBoxResult

If MyPak.ChangedFlag Then

X = MsgBox("Save changes in '" & Mid(MyPak.FileName, InStrRev(MyPak.FileName, "\") + 1) & "'?", vbQuestion + vbYesNoCancel, "RPak Editor")
If X = vbYes Then
mnuFileSave_Click

If MyPak.ChangedFlag Then Cancel = 1: Exit Sub
ElseIf X = vbNo Then

ElseIf X = vbCancel Then
Cancel = 1
End If

End If


If Not Cancel = 1 Then
    PakForms.Remove "pf" & PakFileID
End If
End Sub

Private Sub imgSize_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
picSizer_MouseDown Button, Shift, X, Y
End Sub

Private Sub imgSize_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
picSizer_MouseDown Button, Shift, X, Y
End Sub

Private Sub lvw_AfterLabelEdit(Cancel As Integer, NewString As String)
CurrentFolder.FileName(CurrentFolder.FindFile(lvw.SelectedItem.Text)) = NewString
UpdateCtls
End Sub

Private Sub lvw_DblClick()
    If lvw.SelectedItem Is Nothing Then Exit Sub
    
    Call mnuContextFileView_Click
End Sub

Private Sub lvw_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If lvw.SelectedItem Is Nothing Then Exit Sub

If Button = vbRightButton Then
PopupMenu mnuContextFile
End If
End Sub

Private Sub lvw_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo fehler:
Dim i As Integer


For i = 1 To Data.Files.Count
    If IsDirectory(Data.Files(i)) Then
    AddFilesRecursive Data.Files(i), CurrentFolder
    Else
    AddFile Data.Files(i)
    End If
Next i

UpdateCtls


Exit Sub
fehler:
Beep
End Sub

Public Sub AddFilesRecursive(Path As String, _
                             Folder As cRPakFolder)
    Dim X As String
    Dim nf As cRPakFolder


    Dim i As Integer
    Dim r As VbMsgBoxResult
    Dim s As String
    
    s = Mid(Path, InStrRev(Path, "\") + 1)
    i = Folder.FindFolder(s)
    
    If i >= 0 Then
        Set nf = Folder.Folders(i)
    Else
        Set nf = Folder.AddFolder(s)
    End If
    
    
    X = Dir(Path & "\*.*")

    Do Until X = ""

        i = nf.FindFile(X)
        If i >= 0 Then
            r = MsgBox("File '" & X & "' already exists. Replace it?", vbQuestion + vbOKCancel, "File already exists")
            If r = vbOK Then
                nf.FileContent(i) = File2Str(Path & "\" & X)
            End If
        Else
            nf.AddFile X, File2Str(Path & "\" & X)
        End If

        X = Dir()
    Loop

    Dim filestoadd As New Collection

    X = Dir(Path & "\", vbDirectory)

    Do Until X = ""

        If Not (X = "." Or X = "..") Then
            If IsDirectory(Path & "\" & X) Then filestoadd.Add Path & "\" & X
        End If

        X = Dir()
    Loop


    For i = 1 To filestoadd.Count
        AddFilesRecursive filestoadd(i), nf
    Next i

End Sub

Public Function IsDirectory(p As String)
IsDirectory = ((GetAttr(p) And vbDirectory) = vbDirectory)
End Function

Public Sub AddFile(FileName As String)
    Dim i As Integer, s As String
    Dim r As VbMsgBoxResult
    
    s = Mid(FileName, InStrRev(FileName, "\") + 1)
    i = CurrentFolder.FindFile(s)

    If i >= 0 Then
        r = MsgBox("File '" & s & "' already exists. Replace it?", vbQuestion + vbOKCancel, "File already exists")

        If r = vbOK Then
            CurrentFolder.FileContent(i) = File2Str(FileName)
        End If

    Else

        If Not CurrentFolder.AddFile(s, File2Str(FileName)) Then
            MsgBox MyPak.ErrDesc, vbCritical, MyPak.ErrSource
        End If
    End If

End Sub

Private Sub lvw_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
If lvw.SelectedItem Is Nothing Then Exit Sub

Data.Clear
Data.Files.Clear
Data.SetData , vbCFFiles


Dim tp As String
tp = String(260, Chr(0))

GetTempPath Len(tp), tp
tp = Replace(tp, Chr(0), "")

Dim fn As String
fn = tp & lvw.SelectedItem.Text

If FileExists(fn) Then Kill fn

Open fn For Binary Access Write As 1
Put #1, , CurrentFolder.FileContent(CurrentFolder.FindFile(lvw.SelectedItem.Text))
Close 1

Data.Files.Add fn

AllowedEffects = vbDropEffectCopy Or vbDropEffectMove
End Sub

Private Sub mnuContextFileDelete_Click()
If Not CurrentFolder.DeleteFile(CurrentFolder.FindFile(lvw.SelectedItem.Text)) Then MsgBox MyPak.ErrDesc, vbCritical, MyPak.ErrSource
UpdateCtls
End Sub

Private Sub mnuContextFileExtract_Click()

cdlFile.Filter = "All files (*.*)|*.*"
cdlFile.DialogTitle = "Extract file from RPAK"
cdlFile.ShowSave

If cdlFile.FileName = "" Then Exit Sub

Dim fc As String

fc = CurrentFolder.FileContent(CurrentFolder.FindFile(lvw.SelectedItem.Text))

Dim ff As Integer
ff = FreeFile

Open cdlFile.FileName For Binary Access Write As ff
Put #ff, , fc
Close 1

End Sub

Private Sub mnuContextFileRename_Click()
lvw.StartLabelEdit
End Sub

Private Sub mnuContextFileView_Click()
Dim frm As frmPreview
Set frm = New frmPreview
frm.txtPreview.Text = CurrentFolder.FileContent(CurrentFolder.FindFile(lvw.SelectedItem.Text))
frm.Show
End Sub

Private Sub mnuContextFolderAdd_Click()
Dim fname As String

fname = FindFreeFolderName("New Folder")

CurrentFolder.AddFolder fname
UpdateCtls
End Sub

Public Function FindFreeFolderName(DesiredFName As String)
If CurrentFolder.FindFolder(DesiredFName) = -1 Then FindFreeFolderName = DesiredFName: Exit Function

Dim i As Integer
i = 1
Do
i = i + 1
If CurrentFolder.FindFolder(DesiredFName & " " & i) = -1 Then FindFreeFolderName = DesiredFName & " " & i: Exit Function
Loop
End Function

Private Sub mnuContextFolderDelete_Click()
If CurrentFolder.IsRoot Then MsgBox "Cannot delete Root!", vbCritical, "Error": Exit Sub

Dim fname As String
fname = CurrentFolder.FolderName

Set CurrentFolder = CurrentFolder.MyParent
If Not CurrentFolder.DeleteFolder(CurrentFolder.FindFolder(fname)) Then MsgBox MyPak.ErrDesc, vbCritical, MyPak.ErrSource

UpdateCtls
End Sub

Private Sub mnuContextFolderRename_Click()
trv.StartLabelEdit
End Sub

Private Sub mnuFileNew_Click()
mdiMain.mnuFileNew_Click
End Sub

Private Sub mnuFileOpen_Click()
mdiMain.mnuFileOpen_Click
End Sub

Private Sub mnuFilePassword_Click()
Dim p As String
p = PasswordBox("Please enter the OLD password:", True)

If Not MyPak.Password = p Then MsgBox "Invalid Password.", vbCritical, "Error": Exit Sub

Dim p2 As String
p = PasswordBox("Please specify a NEW password:", True)
p2 = PasswordBox("Please repeat the NEW password:", True)

If Not p = p2 Then MsgBox "The passwords differ. Please re-check your typing.", vbCritical, "Error": Exit Sub

MyPak.Password = p

UpdateCtls
End Sub

Private Sub mnuFileQuit_Click()
mdiMain.mnuFileQuit_Click
End Sub

Private Sub mnuFileSave_Click()
If Not MyPak.FileSave(MyPak.FileName) Then MsgBox MyPak.ErrDesc, vbCritical, MyPak.ErrSource
UpdateCtls
End Sub

Private Sub mnuFileSaveAs_Click()

cdlFile.Filter = "R-PG Pak Files (*.rpak)|*.rpak"
cdlFile.ShowSave

If cdlFile.FileName = "" Then Exit Sub
If Not MyPak.FileSave(cdlFile.FileName) Then MsgBox MyPak.ErrDesc, vbCritical, MyPak.ErrSource
UpdateCtls
End Sub

Private Sub mnuHelpAbout_Click()
mdiMain.mnuHelpAbout_Click
End Sub

Private Sub picSizer_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
s_x = X
s_y = Y
Dragging = True
End Sub

Private Sub picSizer_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
If Dragging Then
    trv.Width = trv.Width - (s_x - X)
    s_x = X
    Form_Resize
End If
End If
End Sub

Private Sub picSizer_Paint()
Dim Y As Long

For Y = 0 To picSizer.ScaleHeight Step imgSize.Height
    picSizer.PaintPicture imgSize.Picture, 0, Y
Next Y
End Sub

Private Sub trv_AfterLabelEdit(Cancel As Integer, NewString As String)

CurrentFolder.FolderName = NewString
UpdateCtls
End Sub

Private Sub trv_Click()
If trv.SelectedItem Is Nothing Then Exit Sub

Dim p As String
p = trv.SelectedItem.FullPath

If Not trv.SelectedItem Is RootNode Then ListFolderByPath Mid(p, Len(RootNode.Text) + 2) Else ListFolderByPath ""

End Sub

Private Sub trv_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
trv_Click

If trv.SelectedItem Is Nothing Then Exit Sub
If Button = vbRightButton Then
PopupMenu mnuContextFolder

End If

End Sub

Private Sub trv_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
lvw_OLEDragDrop Data, Effect, Button, Shift, X, Y
End Sub


Public Function GetIconForType(TypeName As String) As Integer
Dim i As Integer
i = FindListImage("ft_" & TypeName)

If i = 0 Then
    GetIconForType = MakeNewTypeIcon(TypeName)
Else
    GetIconForType = i
End If
End Function

Public Function FindListImage(Key As String) As Integer
    Dim i As Integer
    For i = 1 To iml.ListImages.Count
        If LCase$(iml.ListImages(i).Key) = LCase$(Key) Then FindListImage = i: Exit Function
    Next i
End Function

Public Function MakeNewTypeIcon(TypeName As String) As Integer
Dim tp As String
tp = Icon_GetTempPath(TypeName)

Dim ff As Integer
ff = FreeFile

Open tp For Output As ff
Close ff


iml.ListImages.Add , "ft_" & TypeName, GetDisplayedIcon(tp, shgfiSmall)

Kill tp

MakeNewTypeIcon = iml.ListImages.Count
End Function

Private Function Icon_GetTempPath(TypeName As String) As String
Dim i As Integer
Dim f As String
Do
i = i + 1

f = App.Path & "\" & TypeName & i & "." & TypeName
If Dir(f) = "" Then Exit Do
Loop

Icon_GetTempPath = f
End Function

Private Sub trv_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
Dim n As Node
Set n = trv.HitTest(X, Y)
Set trv.SelectedItem = n
trv_Click
End Sub
