DP Tool Club 22/CD_ASCQ_22_0695.iso/win/prg/zipserv/ddezip.fr_/ddezip.fr

Text File | 1995-01-29 | 17KB | 564 lines

VERSION 2.00
Begin Form ZipForm
   AutoRedraw      =   -1  'True
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "Compression Plus Quick Demo"
   ClientHeight    =   2448
   ClientLeft      =   1020
   ClientTop       =   1476
   ClientWidth     =   7248
   Height          =   2868
   Icon            =   DDEZIP.FRX:0000
   Left            =   972
   LinkMode        =   1  'Source
   LinkTopic       =   "ZipForm"
   ScaleHeight     =   2448
   ScaleWidth      =   7248
   Top             =   1104
   Width           =   7344
   Begin SSCheck KeepDate
      Caption         =   "&Keep Date"
      Font3D          =   0  'None
      Height          =   276
      Left            =   5256
      TabIndex        =   19
      Top             =   288
      Width           =   1788
   End
   Begin TextBox txtComment
      Height          =   324
      Left            =   1092
      TabIndex        =   17
      Text            =   " "
      Top             =   1224
      Width           =   3936
   End
   Begin CommandButton HideButton
      Caption         =   "&Hide"
      Height          =   396
      Left            =   7092
      TabIndex        =   16
      Top             =   1884
      Width           =   972
   End
   Begin SSCheck Overwrite
      Caption         =   "&Overwrite existing"
      Enabled         =   0   'False
      Font3D          =   0  'None
      Height          =   312
      Left            =   1776
      TabIndex        =   14
      Top             =   2052
      Width           =   1644
   End
   Begin SSCheck Hidden
      Caption         =   "&Hidden Process"
      Font3D          =   0  'None
      Height          =   312
      Left            =   1788
      TabIndex        =   13
      Top             =   1632
      Value           =   -1  'True
      Width           =   1524
   End
   Begin TextBox Password
      Height          =   312
      HelpContextID   =   37
      Left            =   5292
      PasswordChar    =   "#"
      TabIndex        =   12
      Top             =   1092
      Width           =   1752
   End
   Begin SSCheck StorePath
      Caption         =   "&Store path"
      Font3D          =   0  'None
      Height          =   276
      Left            =   5256
      TabIndex        =   11
      Top             =   516
      Width           =   1788
   End
   Begin SSCheck chkPassword
      Caption         =   "Pass&word"
      Font3D          =   0  'None
      Height          =   288
      Left            =   5256
      TabIndex        =   10
      Top             =   732
      Width           =   1788
   End
   Begin CSOptList optTask
      Alignment       =   0  'Left
      BorderEffect    =   0  'None
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Task"
      Contents        =   DDEZIP.FRX:0302
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   "6.5"
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   888
      ItemAlignment   =   0  'Left
      ItemFontBold    =   -1  'True
      ItemFontItalic  =   0   'False
      ItemFontName    =   "MS Sans Serif"
      ItemFontSize    =   "6.5"
      ItemFontStrikethru=   0   'False
      ItemFontUnderline=   0   'False
      ItemForeColor   =   &H00000000&
      Left            =   5280
      LeftMargin      =   240
      ListIndex       =   0
      ShadowColor     =   &H00808080&
      Spacing         =   240
      TabIndex        =   9
      ThreeD          =   -1  'True
      Top             =   1488
      TopMargin       =   300
      Width           =   1764
   End
   Begin SSCheck Recursive
      Caption         =   "&Recurse"
      Font3D          =   0  'None
      Height          =   312
      Left            =   5244
      TabIndex        =   8
      Top             =   36
      Width           =   1788
   End
   Begin TextBox Text3
      Height          =   324
      Left            =   1104
      TabIndex        =   6
      Text            =   " "
      Top             =   852
      Width           =   3936
   End
   Begin TextBox Text2
      Height          =   324
      Left            =   1104
      TabIndex        =   5
      Text            =   " "
      Top             =   492
      Width           =   3936
   End
   Begin TextBox Text1
      Height          =   324
      Left            =   1104
      TabIndex        =   3
      Text            =   " "
      Top             =   144
      Width           =   3936
   End
   Begin CommandButton Command1
      Caption         =   "E&xit"
      Height          =   855
      Left            =   3492
      TabIndex        =   1
      Top             =   1584
      Width           =   1575
   End
   Begin CommandButton btnExecute
      Caption         =   "&Execute"
      Enabled         =   0   'False
      Height          =   855
      Left            =   108
      TabIndex        =   0
      Top             =   1596
      Width           =   1575
   End
   Begin Label Label4
      BackStyle       =   0  'Transparent
      Caption         =   "Comment"
      Height          =   240
      Left            =   96
      TabIndex        =   18
      Top             =   1260
      Width           =   972
   End
   Begin Label DDELabel
      Caption         =   "Label1"
      Height          =   816
      Left            =   7080
      TabIndex        =   15
      Top             =   132
      Visible         =   0   'False
      Width           =   5124
   End
   Begin Label Label3
      BackStyle       =   0  'Transparent
      Caption         =   "Destination"
      Height          =   240
      Left            =   120
      TabIndex        =   7
      Top             =   900
      Width           =   972
   End
   Begin Label Label2
      BackStyle       =   0  'Transparent
      Caption         =   "Files to ZIP"
      Height          =   240
      Left            =   132
      TabIndex        =   4
      Top             =   552
      Width           =   972
   End
   Begin Label Label1
      BackStyle       =   0  'Transparent
      Caption         =   "ZIP file:"
      Height          =   216
      Left            =   132
      TabIndex        =   2
      Top             =   168
      Width           =   972
   End
End
Option Explicit
Declare Function FindWindow% Lib "User" (ByVal lpClassName As Any, ByVal lpWindowName As Any)
Declare Function ShowWindow% Lib "User" (ByVal hWnd%, ByVal nCmdShow%)
Declare Function APISetFocus% Lib "User" Alias "SetFocus" (ByVal Handle As Integer)
Declare Function GetWindow% Lib "User" (ByVal hWnd%, ByVal wCmd%)
Const SW_HIDE = 0
Const SW_RESTORE = 9
Const GW_OWNER = 4
Dim OwnerHandle%, ZipComment$

Sub btnExecute_Click ()
    Select Case optTask.ListIndex
       Case 0
          btnZip_Click
       Case 1
          btnUnzip_Click
    End Select
End Sub

Sub btnUnzip_Click ()
    Dim ZipFileName$, FileToUnZip$, Destination$, RestorePath As Integer, Passwrd As String
    ZipFileName$ = Text1
    FileToUnZip$ = "*.*"
    Destination$ = Text3
    RestorePath = StorePath
    Passwrd = IIf(chkPassword = True, Trim(Password), "")
    Unzip_It ZipFileName$, Destination$, FileToUnZip$, RestorePath, Passwrd
End Sub

Sub btnZip_Click ()
    Dim ZipFileName$, KepDate As Integer, StorPath As Integer, Passwrd As String, Recurse As Integer
    ReDim FilesToZip$(1 To 1)
    ZipFileName$ = Text1
    FilesToZip$(1) = Text2
    KepDate = KeepDate
    StorPath = StorePath
    Recurse = Recursive
    Passwrd = IIf(chkPassword = True, Trim(Password), "")
    Zip_It ZipFileName$, FilesToZip$(), KepDate, StorPath, Recurse, Passwrd
End Sub

Sub chkPassword_Click (Value As Integer)
    If Value Then
       Password.Visible = True
    Else
       Password.Visible = False
    End If
End Sub

Sub Command1_Click ()
    End
End Sub

'Provide DDE Server functions through a single
'hidden label control on DDEForm in HIDE_DDE.EXE:
Sub DDELabel_Change ()
    Dim DDEInstruction$, DDEResponse$, start&
    'This procedure gets *and* sets the Caption property,
    'which can cause event recursion. Therefore, we'll
    'set/check a static variable to prevent recursion.
    Static ChangeActive%
    If ChangeActive% Then Exit Sub
    'Evevnt already active
    ChangeActive% = True
    'Set active flag
    'At this point, the Change event has fired
    'because an instruction has been received via a
    'DDE link. Process the instruction accordingly:

    'DDELabel.Caption holds the request and must be formatted as:
    '  fixed length string, 100 long, the path and name of the ZIP file
    '  1 character long string, value 0 - Zip, 1 - Unzip
    '  fixed lenght string, 100 long,
    '       the path and name (wild characters) of the files to Zip
    '       or
    '       the destination path of the files to unzip
    '  one character
    '       0 or 1 if not zero that keeps the date at zipping, overwrites at unzipping
    '  one character
    '       0 or 1 if not zero that stores the path at zipping, restores the path at unzipping
    ' there are converting procedures using ZipInfo variable for a structure
    ' From String to zipvalues: GetZipInfo DDELabel.Caption
    ' From Zipvalues to string: s$ = ZipPass$()

    DDEInstruction$ = DDELabel.Caption
    'DDEResponse$ = "I am DDEZIP. Good evening"
    'GoTo ToEnd
    If DDEInstruction$ > "" Then
        GetZipInfo DDEInstruction$

        'Fetch instruction
        Text1 = ZipInfo.ZipFile
        optTask.ListIndex = ZipInfo.Task
        Select Case ZipInfo.Task
           Case 0
              Text2 = ZipInfo.FilesToZip
              KeepDate = ZipInfo.KeepDate
              StorePath = ZipInfo.StorePath
              Recursive = ZipInfo.Recursive
              txtComment = Trim(ZipInfo.Comment)
              Password = Trim(ZipInfo.Password)
           Case Else
              Text3 = ZipInfo.Destination
              Overwrite = ZipInfo.Overwrite
              StorePath = ZipInfo.RestorePath
              Password = Trim(ZipInfo.Password)
        End Select
        If Password > "" Then
           chkPassword = True
        Else
           chkPassword = False
        End If
        'Execute
        btnExecute_Click
        If txtComment > "" Then
           txtComment_LostFocus
        End If
    Else
        'sending Null string terminates ddezip
        End
    End If
    'give back a EndOfProcess message
    DoEvents
    DDELabel.Caption = "-1"
    DDEResponse$ = "-1"
    DoEvents
    'wait for "ACK"
    'start& = Timer
    'Do While Not DDELabel.Caption = "ACK" And Timer - start& < 2
    'Loop
    'give an acknowledgdment to the client application
    'Select Case ZipInfo.Task
    '   Case 0
    '      DDEResponse$ = ZipInfo.ZipFile + " created/updated containing " + ZipInfo.FilesToZip
    '   Case 1
    '      DDEResponse$ = ZipInfo.ZipFile + " exploded to " + ZipInfo.Destination
    'End Select
    'Post status or result back to DDELabel control
    'The DDE client can fetch it if desired.
'ToEnd:
    DDELabel.Caption = DDEResponse$
    ChangeActive% = False
End Sub

Sub Form_Load ()
    Dim FindTitle$, PreviousHandle%, R%
    optTask_Click
    ZipEcho% = False
    OverW% = False
    'Detect if previous instance of this app is loaded
    'The app may be visible or *totally* hidden, so we'll
    'use the FindWindow function to locate and activate
    '(show if hidden, or set focus if already visible)
    'the previous instance
    FindTitle$ = "Hidden DDE Server"
    PreviousHandle% = FindWindow%(0&, FindTitle$)
    If PreviousHandle% Then
       'We found a previous instance
       R% = ShowWindow%(PreviousHandle%, SW_RESTORE)
       'Unhide app
       R% = APISetFocus%(PreviousHandle%)
       'Set focus
       End
       'This (second) instance can now terminate
    Else
       Me.Caption = FindTitle$
       'First instance is loading here
       HideButton_Click
       'Hide this instance
    End If
End Sub

Sub Form_Paint ()
    Dim R%
    If OwnerHandle% Then
       'A second instance has unhidden and set focus to
       'this instance, causing this Form_Paint event
       'to occur. However, only the DDEForm is visible,
       'not the background/owner window. Reinstate this
       'instance in the Task List and ALT+TAB order by
       'unhiding the background/owner window:
       R% = ShowWindow(OwnerHandle%, SW_RESTORE)
       'Reset handle variable for next
       'hide/show/paint cycle
       OwnerHandle% = 0
    Else
       'OwnerHandle% is zero, so this instance is not
       'currently hidden
    End If
End Sub

Sub Hidden_Click (Value As Integer)
    ZipEcho% = Not Value
End Sub

Sub HideButton_Click ()
    Dim R%
    Me.Hide
    'Get the handle of this application's
    'background/owner:
    OwnerHandle% = GetWindow(Me.hWnd, GW_OWNER)
    'Hide the background/owner window, thereby removing
    'this app from the Task List and ALT+TAB order:
    R% = ShowWindow(OwnerHandle%, SW_HIDE)
End Sub

Sub optTask_Click ()
    Select Case optTask.ListIndex
       Case 0
          KeepDate.Enabled = True
          StorePath.Caption = "&Store Path"
          Label2.Visible = True
          Text2.Visible = True
          Label3.Visible = False
          Text3.Visible = False
          Overwrite.Enabled = False
          Text2_Change
       Case 1
          KeepDate.Enabled = False
          StorePath.Caption = "Re&store Path"
          Label2.Visible = False
          Text2.Visible = False
          Label3.Visible = True
          Text3.Visible = True
          Overwrite.Enabled = True
          Text3_Change
    End Select
End Sub

Sub Overwrite_Click (Value As Integer)
    OverW% = Value
End Sub

Sub Text1_Change ()
    Dim d$, f$
    On Error GoTo NotAPath
    d$ = ExtractPath(Trim(Text1))
    If Len(d$) > 3 And Right$(d$, 1) = "\" Then
       d$ = Left$(d$, Len(d$) - 1)
    End If
    If Trim(d$) > "" Then
        If GetAttr(Trim(d$)) = 16 Then
           f$ = ExtractFile(Trim(Text1))
           If (Len(f$) <= 8 And Len(f$) > 0) Or (Len(f$) > 4 And Len(f$) <= 12 And Right$(UCase$(f$), 4) = ".ZIP") Then
              Text1.Tag = True
           Else
              Text1.Tag = False
           End If
        Else
            Text1.Tag = False
        End If
    Else
        Text1.Tag = False
    End If

Text1Exit:
    If optTask.ListIndex = 0 Then
        If Val(Text1.Tag) And Val(Text2.Tag) Then
           btnExecute.Enabled = True
        Else
           btnExecute.Enabled = False
        End If
    Else
        If Val(Text1.Tag) And Val(Text3.Tag) Then
           btnExecute.Enabled = True
        Else
           btnExecute.Enabled = False
        End If
    End If
    Exit Sub
NotAPath:
    Text1.Tag = False
    Resume Text1Exit
End Sub

Sub Text2_Change ()
    If optTask.ListIndex = 0 Then
       If Trim(Text2) > "" Then
          If Len(Dir$(Trim(Text2))) > 0 Then
             Text2.Tag = True
          Else
             Text2.Tag = False
          End If
       Else
          Text2.Tag = False
       End If
    End If
    If Val(Text2.Tag) And Val(Text1.Tag) Then
       btnExecute.Enabled = True
    Else
       btnExecute.Enabled = False
    End If
End Sub

Sub Text3_Change ()
    On Error GoTo NotAFile
    If optTask.ListIndex = 1 Then
       If Trim(Text3) > "" Then
          If GetAttr(Trim(Text3)) = 16 Then
             Text3.Tag = True
          Else
             Text3.Tag = False
          End If
       Else
          Text3.Tag = False
       End If
    End If
Text3Exit:
    If Val(Text1.Tag) And Val(Text3.Tag) Then
       btnExecute.Enabled = True
    Else
       btnExecute.Enabled = False
    End If
    Exit Sub
NotAFile:
    Text3.Tag = False
    Resume Text3Exit
End Sub

Sub txtComment_LostFocus ()
    Dim c$, ZipFile$, C_Err_Code%, Handle%

    c$ = Trim(txtComment.Text)
    If c$ <> ZipComment$ Then
        ZipFile$ = RTrim$(Text1)
        C_Err_Code% = EtZipOpen(ZipFile$, 0, Handle%)
        If C_Err_Code% Then GoTo CommentError
        C_Err_Code% = EtZipNewComment(Handle%, c$)
        EtZipClose Handle%
        If C_Err_Code% Then GoTo CommentError
        ZipComment$ = c$
        txtComment.Text = ZipComment$
    End If
    Exit Sub


CommentError:
    MsgBox "Unable to install new comment", 48, "File Write Error"
    txtComment.Text = ZipComment$



End Sub