home *** CD-ROM | disk | FTP | other *** search
VERSION 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX" Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX" Begin VB.Form frmManager BorderStyle = 1 'Fixed Single Caption = "Encoder / Decoder manager" ClientHeight = 5565 ClientLeft = 150 ClientTop = 720 ClientWidth = 8565 LinkTopic = "Form1" MaxButton = 0 'False OLEDropMode = 1 'Manual ScaleHeight = 5565 ScaleWidth = 8565 StartUpPosition = 3 'Windows Default Begin TabDlg.SSTab tabManager Height = 3840 Left = 75 TabIndex = 26 Top = 75 Width = 8415 _ExtentX = 14843 _ExtentY = 6773 _Version = 393216 Style = 1 Tabs = 2 TabsPerRow = 2 TabHeight = 520 TabCaption(0) = "Encode" TabPicture(0) = "Manager.frx":0000 Tab(0).ControlEnabled= -1 'True Tab(0).Control(0)= "lbl(2)" Tab(0).Control(0).Enabled= 0 'False Tab(0).Control(1)= "lbl(3)" Tab(0).Control(1).Enabled= 0 'False Tab(0).Control(2)= "cmdSelectSourceFile" Tab(0).Control(2).Enabled= 0 'False Tab(0).Control(3)= "fraEncodeMethod" Tab(0).Control(3).Enabled= 0 'False Tab(0).Control(4)= "cmdEncode" Tab(0).Control(4).Enabled= 0 'False Tab(0).Control(5)= "txtSourceFile" Tab(0).Control(5).Enabled= 0 'False Tab(0).Control(6)= "txtDestinationFile" Tab(0).Control(6).Enabled= 0 'False Tab(0).Control(7)= "cmdSelectDestinationFile" Tab(0).Control(7).Enabled= 0 'False Tab(0).ControlCount= 8 TabCaption(1) = "Decode" TabPicture(1) = "Manager.frx":001C Tab(1).ControlEnabled= 0 'False Tab(1).Control(0)= "txtDecodedFileName" Tab(1).Control(1)= "cmdSelectDecodeFolder" Tab(1).Control(2)= "txtDecodeFolder" Tab(1).Control(3)= "fraEncoded" Tab(1).Control(4)= "cmdDecode" Tab(1).Control(5)= "fraDecodeMethod" Tab(1).Control(6)= "lbl(1)" Tab(1).Control(7)= "lbl(0)" Tab(1).ControlCount= 8 Begin VB.CommandButton cmdSelectDestinationFile Caption = "..." Height = 285 Left = 6075 TabIndex = 3 Top = 900 Width = 285 End Begin VB.TextBox txtDestinationFile Height = 285 Left = 1500 OLEDropMode = 2 'Automatic TabIndex = 2 Top = 900 Width = 4515 End Begin VB.TextBox txtDecodedFileName Height = 285 Left = -73350 OLEDropMode = 2 'Automatic TabIndex = 17 Top = 3375 Width = 4590 End Begin VB.CommandButton cmdSelectDecodeFolder Caption = "..." Height = 285 Left = -68700 TabIndex = 16 Top = 3000 Width = 285 End Begin VB.TextBox txtDecodeFolder Height = 285 Left = -73350 OLEDropMode = 2 'Automatic TabIndex = 15 Top = 3000 Width = 4590 End Begin VB.Frame fraEncoded Caption = "Encoded file(s)" Height = 2415 Left = -74850 TabIndex = 31 Top = 450 Width = 6240 Begin VB.ListBox lstEncodedFile Height = 1620 Left = 150 MultiSelect = 2 'Extended OLEDropMode = 1 'Manual Sorted = -1 'True TabIndex = 11 Top = 675 Width = 5940 End Begin VB.CommandButton cmdAddEncodedFile Caption = "Add file" Height = 315 Left = 150 OLEDropMode = 1 'Manual TabIndex = 12 Top = 300 Width = 1140 End Begin VB.CommandButton cmdRemoveEncodedFile Caption = "Remove file" Height = 315 Left = 1350 TabIndex = 13 Top = 300 Width = 1140 End Begin VB.CommandButton cmdClearEncodedFile Caption = "Clear" Height = 315 Left = 4950 TabIndex = 14 Top = 300 Width = 1140 End End Begin VB.TextBox txtSourceFile Height = 285 Left = 1500 OLEDropMode = 1 'Manual TabIndex = 0 Top = 525 Width = 4515 End Begin VB.CommandButton cmdEncode Caption = "Encode" Height = 675 Left = 6750 TabIndex = 10 Top = 3000 Width = 1515 End Begin VB.Frame fraEncodeMethod Caption = "Method" Height = 2190 Left = 6450 TabIndex = 30 Top = 450 Width = 1815 Begin VB.OptionButton optEncodeMethod Caption = "BinHex" Height = 240 Index = 5 Left = 150 TabIndex = 9 Top = 1800 Width = 1515 End Begin VB.OptionButton optEncodeMethod Caption = "Quoted printable" Height = 240 Index = 4 Left = 150 TabIndex = 8 Top = 1500 Width = 1515 End Begin VB.OptionButton optEncodeMethod Caption = "Base64" Height = 240 Index = 2 Left = 150 TabIndex = 6 Top = 900 Width = 1515 End Begin VB.OptionButton optEncodeMethod Caption = "UUEncode" Height = 240 Index = 0 Left = 150 TabIndex = 4 Top = 300 Value = -1 'True Width = 1515 End Begin VB.OptionButton optEncodeMethod Caption = "Hexadecimal" Height = 240 Index = 3 Left = 150 TabIndex = 7 Top = 1200 Width = 1515 End Begin VB.OptionButton optEncodeMethod Caption = "XXEncode" Height = 240 Index = 1 Left = 150 TabIndex = 5 Top = 600 Width = 1515 End End Begin VB.CommandButton cmdSelectSourceFile Caption = "..." Height = 285 Left = 6075 TabIndex = 1 Top = 525 Width = 285 End Begin VB.CommandButton cmdDecode Caption = "Decode" Height = 675 Left = -68250 TabIndex = 24 Top = 3000 Width = 1515 End Begin VB.Frame fraDecodeMethod Caption = "Method" Height = 2190 Left = -68550 TabIndex = 29 Top = 450 Width = 1815 Begin VB.OptionButton optDecodeMethod Caption = "BinHex" Height = 240 Index = 5 Left = 150 TabIndex = 23 Top = 1800 Width = 1515 End Begin VB.OptionButton optDecodeMethod Caption = "Quoted printable" Height = 240 Index = 4 Left = 150 TabIndex = 22 Top = 1500 Width = 1515 End Begin VB.OptionButton optDecodeMethod Caption = "XXEncode" Height = 240 Index = 1 Left = 150 TabIndex = 19 Top = 600 Width = 1515 End Begin VB.OptionButton optDecodeMethod Caption = "Hexadecimal" Height = 240 Index = 3 Left = 150 TabIndex = 21 Top = 1200 Width = 1515 End Begin VB.OptionButton optDecodeMethod Caption = "UUEncode" Height = 240 Index = 0 Left = 150 TabIndex = 18 Top = 300 Value = -1 'True Width = 1515 End Begin VB.OptionButton optDecodeMethod Caption = "Base64" Height = 240 Index = 2 Left = 150 TabIndex = 20 Top = 900 Width = 1515 End End Begin VB.Label lbl Caption = "Destination file" Height = 240 Index = 3 Left = 150 TabIndex = 35 Top = 900 Width = 1215 End Begin VB.Label lbl Caption = "Source file" Height = 240 Index = 2 Left = 150 TabIndex = 34 Top = 525 Width = 915 End Begin VB.Label lbl Caption = "Decoded file name" Height = 240 Index = 1 Left = -74850 TabIndex = 33 Top = 3375 Width = 1365 End Begin VB.Label lbl Caption = "Decode in" Height = 240 Index = 0 Left = -74850 TabIndex = 32 Top = 3000 Width = 915 End End Begin MSComDlg.CommonDialog dlgCommon Left = 7950 Top = 3975 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.Frame Frame3 Height = 90 Left = 0 TabIndex = 28 Top = 4050 Width = 8565 End Begin VB.TextBox txtMessage Height = 990 Left = 75 Locked = -1 'True MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 25 Top = 4500 Width = 8415 End Begin VB.Label lbl Caption = "Error / Warning message" Height = 240 Index = 4 Left = 75 TabIndex = 27 Top = 4275 Width = 2565 End Begin VB.Menu mnuFile Caption = "File" Begin VB.Menu mnuQuit Caption = "Quit" End End Begin VB.Menu mnuOption Caption = "Option" End Attribute VB_Name = "frmManager" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False ' Xceed Binary Encoding Library - Encoding Manager sample ' Copyright (c) 2001 Xceed Software Inc. ' [Manager.frm] ' This form module contains the main form's code. It demonstrates how to ' encode a file using different kinds of encoding methods, and decode an ' encoded file. It specifically uses: ' - The ProcessFile method. ' - The EndOfLineType, MaxLineLength, ContinueOnInvalidData, ' HeaderDataForkLength, HeaderResourceForkLength, HeaderFilename, EncodingFormat ' and IncludeHeaderFooter propeties. ' This file is part of the Xceed Binary Encoding Library sample applications. ' The source code in this file is only intended as a supplement to Xceed ' Binary Encoding Library's documentation, and is provided "as is", without ' warranty of any kind, either expressed or implied. Option Explicit 'The tabs from the SSTab control Private Enum enuTabManager tmEncode = 0 tmDecode = 1 End Enum 'The different encoding methods corresponding to the option buttons (the same 'for the Decode and Encode tabs) Private Enum enuEncodingMethod emUUEncode = 0 emXXEncode = 1 emBase64 = 2 emHexadecimal = 3 emQuotedPrintable = 4 emBinHex = 5 End Enum 'The values chosen by the user in the Option form Private m_lMaxLineLength As Long Private m_eEndOfLineType As EXBEndOfLineType Private m_bContinueOnInvalidData As Boolean 'The Encoding and Decoding method chosen by the user from the option buttons Private m_eEncodingMethod As enuEncodingMethod Private m_eDecodingMethod As enuEncodingMethod '==================================================================================== ' EVENTS - triggered by the form and its controls '==================================================================================== '==================================================================================== 'Events relative to the encode process '==================================================================================== '------------------------------------------------------------------------------------ 'Select the source folder and file name that will be encoded by the 'encode action '------------------------------------------------------------------------------------ Private Sub cmdSelectSourceFile_Click() With dlgCommon .FileName = "" .DialogTitle = "Source file" .Filter = "All type (*.*)|*.*" .FilterIndex = 0 .Flags = cdlOFNExplorer On Error Resume Next 'Show an Open common dialog to let the user select a file Call .ShowOpen If Err.Number = 0 Then txtSourceFile.Text = .FileName Call SetDestinationFileName End If On Error GoTo 0 End With End Sub '------------------------------------------------------------------------------------ 'Select the destination and name of the file that will be created by the 'encode action '------------------------------------------------------------------------------------ Private Sub cmdSelectDestinationFile_Click() With dlgCommon .FileName = "" .DialogTitle = "Destination file" .Filter = "Encoded (*.uue;*.xxe;*.b64;*.hex;*.hqx;*.qpr)|*.uue;*.xxe;*.b64;*.hex;*.hqx;*.qpr|UU encoded (*.uue)|*.uue|XX Encoded (*.xxe)|*.xxe|Base 64 (*.b64)|*.b64|Hexadecimal (*.hex)|*.hex|BinHex (*.hqx)|*.hqx|Quoted printable (*.qpr)|*.qpr|All type (*.*)|*.*" .FilterIndex = 0 .Flags = cdlOFNExplorer On Error Resume Next 'Show an Open common dialog to let the user select the destination 'file name Call .ShowOpen If Err.Number = 0 Then txtDestinationFile.Text = .FileName End If On Error GoTo 0 End With End Sub '------------------------------------------------------------------------------------ 'The user changed the selected Encoding method '------------------------------------------------------------------------------------ Private Sub optEncodeMethod_Click(Index As Integer) 'Change the extension of the destination (encoded) file name to be 'consistent with the newly selected encoding method Call SetDestinationFileExtension(m_eEncodingMethod, Index) m_eEncodingMethod = Index End Sub '------------------------------------------------------------------------------------ 'Fill the destination file name to a default value if its empty '------------------------------------------------------------------------------------ Private Sub txtSourceFile_LostFocus() Call SetDestinationFileName End Sub '------------------------------------------------------------------------------------ 'The mouse cursor dropped something in the source file text box '------------------------------------------------------------------------------------ Private Sub txtSourceFile_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Call EncodeDragDrop(Data, Effect) End Sub '------------------------------------------------------------------------------------ 'The mouse cursor is moved over the source file text box '------------------------------------------------------------------------------------ Private Sub txtSourceFile_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) Call EncodeDragOver(Data, Effect) End Sub '------------------------------------------------------------------------------------ 'Do the encoding of the selected source file name to the destination file '------------------------------------------------------------------------------------ Private Sub cmdEncode_Click() 'We do this SetFocus and DoEvents to make sure that, if the user did not used 'the mouse but rather a shortcut to the Encode button, the LostFocus event 'for the current active control and its handling are triggered. cmdEncode.SetFocus DoEvents If Len(Trim(txtSourceFile.Text)) <> 0 Then 'There is something to Encode! Do the encoding If EncodeFile(txtSourceFile.Text, m_eEncodingMethod, m_eEndOfLineType, m_lMaxLineLength, txtDestinationFile.Text) Then 'The encoding was successful, we clear the source and destination 'text boxes. txtSourceFile.Text = "" txtDestinationFile.Text = "" End If End If End Sub '==================================================================================== 'Events relative to the decode process '==================================================================================== '------------------------------------------------------------------------------------ 'Add file(s) to the list of files to Decode '------------------------------------------------------------------------------------ Private Sub cmdAddEncodedFile_Click() Dim sFilenames As String Dim sFilename As String Dim sFolder As String Dim nPos As Integer Dim nOldPos As Integer With dlgCommon .FileName = "" .DialogTitle = "Encoded file" .Filter = "Encoded (*.uue;*.xxe;*.b64;*.hex;*.hqx;*.qpr)|*.uue;*.xxe;*.b64;*.hex;*.hqx;*.qpr|UU encoded (*.uue)|*.uue|XX Encoded (*.xxe)|*.xxe|Base 64 (*.b64)|*.b64|Hexadecimal (*.hex)|*.hex|BinHex (*.hqx)|*.hqx|Quoted printable (*.qpr)|*.qpr|All type (*.*)|*.*" .FilterIndex = 0 .Flags = cdlOFNExplorer Or cdlOFNAllowMultiselect On Error Resume Next 'Show an Open common dialog to let the user select file(s) Call .ShowOpen If Err.Number = 0 Then sFilenames = .FileName nOldPos = 0 'Extract each chosen files which are separated by a binary 0 nPos = InStr(sFilenames, Chr(0)) If nPos > 0 Then 'More than one files were selected. The first 0 delimited string 'contains the folder name of all the following file name. sFolder = Left$(sFilenames, nPos - 1) 'We add a binary 0 to the user selected file names so that the 'last file name of the string while also end by a 0 (the following 'algorithm assume that a file name is always between two binary 0). sFilenames = sFilenames & Chr(0) nOldPos = nPos 'Find the ending position of the file name string nPos = InStr(nOldPos + 1, sFilenames, Chr(0)) While nPos > 0 sFilename = Trim$(Mid$(sFilenames, nOldPos + 1, nPos - nOldPos - 1)) If Len(sFilename) <> 0 Then 'Add the extracted file name to the list box of file names Call AddEncodedFileToList(sFolder & "\" & sFilename) End If 'Set the beginning position of the next file name (the end 'of the previous one). nOldPos = nPos 'Find the end position of the file name string nPos = InStr(nOldPos + 1, sFilenames, Chr(0)) Wend Else 'Only one file was selected by the user. Add it to the list box Call AddEncodedFileToList(sFilenames) End If End If On Error GoTo 0 End With End Sub '------------------------------------------------------------------------------------ 'The mouse cursor dropped something on the Add File button of the Decode tab '------------------------------------------------------------------------------------ Private Sub cmdAddEncodedFile_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Call DecodeDragDrop(Data, Effect) End Sub '------------------------------------------------------------------------------------ 'The mouse cursor is moved over the Add File button of the Decode tab '------------------------------------------------------------------------------------ Private Sub cmdAddEncodedFile_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) Call DecodeDragOver(Data, Effect) End Sub '------------------------------------------------------------------------------------ 'Remove the selected file from the "files to decode" list box '------------------------------------------------------------------------------------ Private Sub cmdRemoveEncodedFile_Click() Dim nFirstItem As Integer Dim nNbItemRemoved As Integer Dim nNbItemToRemove As Integer Dim nNbItem As Integer Dim i As Integer With lstEncodedFile nNbItemToRemove = .SelCount If nNbItemToRemove <> 0 Then 'Check each file in the files to decode list box and, if it is 'selected, remove it from the list nNbItem = .ListCount For i = nNbItem - 1 To 0 Step -1 If .Selected(i) Then Call .RemoveItem(i) nNbItemRemoved = nNbItemRemoved + 1 nNbItem = nNbItem - 1 If nNbItemRemoved = nNbItemToRemove Then 'We removed the original number of files selected. We set 'the new item to select in the file list (the file that 'follows the last selected item) and exit the loop. nFirstItem = i Exit For End If End If Next If nNbItem <> 0 Then 'There is at least one file left in the list If nFirstItem >= nNbItem Then 'There was no file after the last removed. We select the last 'file of the list .Selected(nNbItem - 1) = True Else .Selected(nFirstItem) = True End If End If End If End With End Sub '------------------------------------------------------------------------------------ 'Remove all item from the Encoded file(s) list box '------------------------------------------------------------------------------------ Private Sub cmdClearEncodedFile_Click() lstEncodedFile.Clear End Sub '------------------------------------------------------------------------------------ 'The user pressed a key while in the encoded file(s) list box. '------------------------------------------------------------------------------------ Private Sub lstEncodedFile_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case vbKeyDelete Call cmdRemoveEncodedFile_Click Case vbKeyInsert Call cmdAddEncodedFile_Click End Select End Sub '------------------------------------------------------------------------------------ 'The mouse cursor dropped something in the encoded file(s) list box '------------------------------------------------------------------------------------ Private Sub lstEncodedFile_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Call DecodeDragDrop(Data, Effect) End Sub '------------------------------------------------------------------------------------ 'The mouse cursor is moved over the encoded file(s) list box '------------------------------------------------------------------------------------ Private Sub lstEncodedFile_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) Call DecodeDragOver(Data, Effect) End Sub '------------------------------------------------------------------------------------ 'Select a folder that will contain the decoded files '------------------------------------------------------------------------------------ Private Sub cmdSelectDecodeFolder_Click() Dim sFolder As String 'By default the browse folder window will be positionned in the currently 'selected Decode folder sFolder = txtDecodeFolder.Text If BrowseFolder(Me.hwnd, "Decode folder", sFolder) Then txtDecodeFolder.Text = sFolder End If End Sub '------------------------------------------------------------------------------------ 'The user changed the selected Decoding method '------------------------------------------------------------------------------------ Private Sub optDecodeMethod_Click(Index As Integer) m_eDecodingMethod = Index End Sub '------------------------------------------------------------------------------------ 'Do the decoding of the selected source file(s) to the selected destination '------------------------------------------------------------------------------------ Private Sub cmdDecode_Click() Dim sDecodedFileName As String Dim matsEncodedFile() As String Dim nNbEncodedFile As Integer Dim i As Integer sDecodedFileName = txtDecodedFileName.Text If Len(sDecodedFileName) = 0 And m_eDecodingMethod <> emUUEncode And m_eDecodingMethod <> emXXEncode Then 'No decode file name was entered by the user. Use the file name of the 'first item in the "Encoded file(s)" list box sDecodedFileName = RemoveFileExtension(ExtractFileName(lstEncodedFile.List(0))) & ".bin" If Len(sDecodedFileName) <> 0 Then txtDecodedFileName.Text = sDecodedFileName End If End If nNbEncodedFile = lstEncodedFile.ListCount If nNbEncodedFile <> 0 Then 'Fill a string array with all the encoded file names of the list box ReDim matsEncodedFile(nNbEncodedFile) For i = 0 To nNbEncodedFile - 1 matsEncodedFile(i) = lstEncodedFile.List(i) Next 'Do the decoding If DecodeFile(matsEncodedFile, nNbEncodedFile, m_eDecodingMethod, m_bContinueOnInvalidData, txtDecodeFolder.Text, sDecodedFileName) Then 'The decoding was successful. We clear the file source list box and the 'destination text box. txtDecodeFolder = "" txtDecodedFileName = "" lstEncodedFile.Clear End If End If End Sub '==================================================================================== 'Events - others '==================================================================================== '------------------------------------------------------------------------------------ 'Prepare the main window by assigning default values and last saved options '------------------------------------------------------------------------------------ Private Sub Form_Load() m_eEncodingMethod = emUUEncode m_eDecodingMethod = emUUEncode optEncodeMethod(m_eEncodingMethod).Value = True optDecodeMethod(m_eDecodingMethod).Value = True lstEncodedFile.Clear Call LoadOption Call tabManager_Click(0) End Sub '------------------------------------------------------------------------------------ 'The mouse cursor dropped something on the form. Do something according to 'the selected tab. '------------------------------------------------------------------------------------ Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) Select Case tabManager.Tab Case tmEncode ' Encode Call EncodeDragDrop(Data, Effect) Case tmDecode ' Decode Call DecodeDragDrop(Data, Effect) End Select End Sub '------------------------------------------------------------------------------------ 'The mouse cursor is moved over the form '------------------------------------------------------------------------------------ Private Sub Form_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) Select Case tabManager.Tab Case tmEncode ' Encode Call EncodeDragOver(Data, Effect) Case tmDecode ' Decode Call DecodeDragOver(Data, Effect) End Select End Sub '------------------------------------------------------------------------------------ 'The user selected the Option menu '------------------------------------------------------------------------------------ Private Sub mnuOption_Click() Dim xFrmOption As frmOption 'Show the options form Set xFrmOption = New frmOption If xFrmOption.ShowForm(m_lMaxLineLength, m_eEndOfLineType, m_bContinueOnInvalidData) Then 'The user clicked OK. Save the options in the registry Call SaveOption End If Set xFrmOption = Nothing End Sub '------------------------------------------------------------------------------------ 'The user selected the Quit option in the menu '------------------------------------------------------------------------------------ Private Sub mnuQuit_Click() End End Sub '------------------------------------------------------------------------------------ 'The user changed the selected tab. '------------------------------------------------------------------------------------ Private Sub tabManager_Click(PreviousTab As Integer) 'Change the default button according to the selected tab Select Case tabManager.Tab Case tmEncode ' Encode cmdEncode.Default = True Case tmDecode ' Decode cmdDecode.Default = True End Select End Sub '==================================================================================== ' FUNCTIONS '==================================================================================== '==================================================================================== 'Functions relative to the encode process '==================================================================================== '------------------------------------------------------------------------------------ 'The mouse cursor dropped something in the encode part of the form. 'If it's a file, we set the source file to encode to the first item (file) of the 'object. Hence, in a multiple files dropping, only the first is considered. '------------------------------------------------------------------------------------ Private Sub EncodeDragDrop(ByRef xData As DataObject, _ ByRef lEffect As Long) Dim sFile As Variant If xData.GetFormat(vbCFFiles) Then txtSourceFile.Text = xData.Files(1) End If lEffect = vbDropEffectNone End Sub '------------------------------------------------------------------------------------ 'The mouse cursor is moved over the encode part of the form. 'If it's a file, we show an icon telling the user (s)he can drop it. 'Otherwise, we show a no-drop icon. '------------------------------------------------------------------------------------ Private Sub EncodeDragOver(ByRef xData As DataObject, _ ByRef lEffect As Long) If xData.GetFormat(vbCFFiles) Then lEffect = vbDropEffectCopy Else lEffect = vbDropEffectNone End If End Sub '------------------------------------------------------------------------------------ 'If a destination file name already exist for encoding, change its extension for 'a new one appropriate to the new encoding method '------------------------------------------------------------------------------------ Private Sub SetDestinationFileExtension(ByVal eOldEncodingMethod As enuEncodingMethod, _ ByVal eNewEncodingMethod As enuEncodingMethod) Dim sDestinationFile As String Dim sDestinationFileExtension As String Dim bChangeExtension As Boolean bChangeExtension = False sDestinationFile = txtDestinationFile.Text sDestinationFileExtension = UCase(ExtractFileExtension(sDestinationFile)) 'If there is a destination file, we verify if its extension correspond to the 'old encoding method. If it correspond or if there is no extension, we set 'the flag that will do the change of extension below If Len(sDestinationFile) <> 0 Then Select Case eOldEncodingMethod Case emUUEncode If sDestinationFileExtension = "UUE" Or _ Len(sDestinationFileExtension) = 0 Then bChangeExtension = True End If Case emXXEncode If sDestinationFileExtension = "XXE" Or _ Len(sDestinationFileExtension) = 0 Then bChangeExtension = True End If Case emBase64 If sDestinationFileExtension = "B64" Or _ Len(sDestinationFileExtension) = 0 Then bChangeExtension = True End If Case emHexadecimal If sDestinationFileExtension = "HEX" Or _ Len(sDestinationFileExtension) = 0 Then bChangeExtension = True End If Case emQuotedPrintable If sDestinationFileExtension = "QPR" Or _ Len(sDestinationFileExtension) = 0 Then bChangeExtension = True End If Case emBinHex If sDestinationFileExtension = "HQX" Or _ Len(sDestinationFileExtension) = 0 Then bChangeExtension = True End If End Select End If 'If we determined above that a change of extension is in order. Do it If bChangeExtension Then sDestinationFile = RemoveFileExtension(sDestinationFile) & StdFileExtension(eNewEncodingMethod) txtDestinationFile.Text = sDestinationFile End If End Sub '------------------------------------------------------------------------------------ 'Set a default destination file name used for the encoding process. This file name 'is derived from the source file name. 'If a destination file name is already specified, do nothing. '------------------------------------------------------------------------------------ Private Sub SetDestinationFileName() Dim sEncodedFileName As String sEncodedFileName = txtDestinationFile.Text If Len(sEncodedFileName) = 0 Then sEncodedFileName = RemoveFileExtension(txtSourceFile) If Len(sEncodedFileName) <> 0 Then txtDestinationFile.Text = sEncodedFileName Call SetDestinationFileExtension(m_eEncodingMethod, m_eEncodingMethod) End If End If End Sub '------------------------------------------------------------------------------------ 'Encode a file! '------------------------------------------------------------------------------------ Private Function EncodeFile(ByVal sSourceFileName As String, _ ByVal eMethod As enuEncodingMethod, _ ByVal eEndOfLineType As EXBEndOfLineType, _ ByVal lMaxLineLength As Long, _ ByVal sEncodedFileName As String) As Boolean Dim xEncoder As XceedBinaryEncoding Dim lErrNumber As Long Dim sErrDesc As String Dim lBytesWritten As Long Dim lBytesRead As Long EncodeFile = False Me.MousePointer = vbHourglass 'Create an instance of the Xceed binary encoding Set xEncoder = New XceedBinaryEncoding 'Create and prepare the encoding format (XX, UU, BinHex, ...) If CreateEncodingFormat(eMethod, xEncoder) Then 'Set the End of line type and the Maximum line length of the chosen 'encoding format xEncoder.EncodingFormat.EndOfLineType = eEndOfLineType xEncoder.EncodingFormat.MaxLineLength = lMaxLineLength If eMethod = emBinHex Then 'For the BinHex format, we must specify the data fork length and the 'resource fork length xEncoder.EncodingFormat.HeaderDataForkLength = FileLen(sSourceFileName) xEncoder.EncodingFormat.HeaderResourceForkLength = 0 End If 'If no extension for the destination file name was provided by the user, 'we set a default one (according the the encoding method) If Len(ExtractFileExtension(sEncodedFileName)) = 0 Then sEncodedFileName = sEncodedFileName & StdFileExtension(eMethod) End If 'Clear the error message and status txtMessage.Text = "" lErrNumber = 0 If lErrNumber = 0 Then On Error Resume Next 'Encode the file, specifying that : ' We want to encode all the source file name (0,0 parameters) ' This is the end of data, no more file to encode will follow (True parameter) ' We want to overwrite a possibly existing destination file (False parameter) lBytesWritten = xEncoder.ProcessFile(sSourceFileName, 0, 0, bfpEncode, True, sEncodedFileName, False, lBytesRead) 'Keep the eventual error code and description as it is reset by the 'On error goto 0 lErrNumber = Err.Number sErrDesc = Err.Description On Error GoTo 0 End If If lErrNumber <> 0 Then 'Display the error that occured txtMessage.Text = sSourceFileName & " fail to encode" & vbCrLf & vbCrLf & _ sErrDesc & " (" & Hex(lErrNumber) & ")" Else 'Display a message of success EncodeFile = True txtMessage = sSourceFileName & " successfully encoded in " & sEncodedFileName End If End If 'Deallocate the Encoding object. The encoding object will free 'the EncodingFormat object. Set xEncoder = Nothing Me.MousePointer = vbDefault End Function '==================================================================================== 'Functions relative to the decode process '==================================================================================== '------------------------------------------------------------------------------------ 'The mouse cursor dropped something in the decode part of the form. 'If it's a file, we add it to the list of files to decode. 'The object dropped can contain more than one file. '------------------------------------------------------------------------------------ Private Sub DecodeDragDrop(ByRef xData As DataObject, _ ByRef lEffect As Long) Dim sFile As Variant If xData.GetFormat(vbCFFiles) Then For Each sFile In xData.Files Call AddEncodedFileToList(sFile) Next End If lEffect = vbDropEffectNone End Sub '------------------------------------------------------------------------------------ 'The mouse cursor is moved over the decode part of the form. 'If it's a file, we show an icon telling the user (s)he can drop it. 'Otherwise, we show a no-drop icon. '------------------------------------------------------------------------------------ Private Sub DecodeDragOver(ByRef xData As DataObject, _ ByRef lEffect As Long) If xData.GetFormat(vbCFFiles) Then lEffect = vbDropEffectCopy Else lEffect = vbDropEffectNone End If End Sub '------------------------------------------------------------------------------------ 'Add the specified file name to the list box of file names to decode '------------------------------------------------------------------------------------ Private Sub AddEncodedFileToList(ByVal sFilename As String) Dim i As Integer Dim bFound As Boolean Dim nNbItem As Integer Dim sDecodeFolder As String nNbItem = lstEncodedFile.ListCount 'Do not allow more than 1000 files to be decoded in a one-shot decode If nNbItem < 1000 Then 'Check if the file name is already in the list of files For i = 0 To nNbItem If lstEncodedFile.List(i) = sFilename Then bFound = True Exit For End If Next If Not bFound Then 'Add the file name to the list Call lstEncodedFile.AddItem(sFilename) 'If no decode folder is specified, set one to the folder name of the 'added file name. sDecodeFolder = txtDecodeFolder.Text If Len(sDecodeFolder) = 0 Then sDecodeFolder = ExtractFolder(sFilename) If Len(sDecodeFolder) <> 0 Then txtDecodeFolder.Text = sDecodeFolder End If End If 'If it's the first file added to the list, select it in the list If nNbItem = 0 Then lstEncodedFile.Selected(0) = True End If 'Set the decoding method according to the file name extension Select Case UCase(Right(sFilename, 4)) Case ".UUE" m_eDecodingMethod = emUUEncode optDecodeMethod(m_eDecodingMethod).Value = True Case ".XXE" m_eDecodingMethod = emXXEncode optDecodeMethod(m_eDecodingMethod).Value = True Case ".B64" m_eDecodingMethod = emBase64 optDecodeMethod(m_eDecodingMethod).Value = True Case ".HEX" m_eDecodingMethod = emHexadecimal optDecodeMethod(m_eDecodingMethod).Value = True Case ".QPR" m_eDecodingMethod = emQuotedPrintable optDecodeMethod(m_eDecodingMethod).Value = True Case ".HQX" m_eDecodingMethod = emBinHex optDecodeMethod(m_eDecodingMethod).Value = True End Select End If End If End Sub '------------------------------------------------------------------------------------ 'Decode file(s)! 'If more than one source file was specified by the user; they will be decoded 'in the same destination file (showing an example of the bAppend paramater). '------------------------------------------------------------------------------------ Private Function DecodeFile(sEncodedFile() As String, _ ByVal nNbEncodedFile As String, _ ByVal eMethod As enuEncodingMethod, _ ByVal bContinueOnInvalidData As Boolean, _ ByVal sDecodeFolder As String, _ ByRef sDecodedFileName As String) As Boolean Dim xEncoder As XceedBinaryEncoding Dim lErrNumber As Long Dim sErrDesc As String Dim i As Integer Dim lBytesRead As Long DecodeFile = False Me.MousePointer = vbHourglass If Right(sDecodeFolder, 1) <> "\" Then 'The Decode folder must end with a \ sDecodeFolder = sDecodeFolder & "\" End If 'Create an instance of the Xceed binary encoding Set xEncoder = New XceedBinaryEncoding 'Create and prepare the encoding format (XX, UU, BinHex, ...) If CreateEncodingFormat(eMethod, xEncoder) Then 'Tell whether or not we want to ignore invalid character in the file(s) 'to decode xEncoder.EncodingFormat.ContinueOnInvalidData = bContinueOnInvalidData 'Clear the error message and status txtMessage.Text = "" lErrNumber = 0 If lErrNumber = 0 Then 'Assume all will succeed. DecodeFile = True For i = 0 To nNbEncodedFile - 1 On Error Resume Next 'Decode a source file, specifying: ' We want to decode all the source file name (0,0 parameters) ' This is the end of data only for the last source file of the ' EncodedFile array [(i = nbEncodedFile -1) parameter] ' We know the destination folder. For the first call, sDecodedFileName ' may be empty for 3 encoding method (BinHex, XX or UU). In that ' case, the EncodingFormat object will have the Filename set ' at the first call. (sDecodeFolder & sDecodedFileName parameter) ' We want to overwrite a possibly existing destination file only ' at the first call. For the other calls, we tell that we want ' to append ( (i <> 0) parameter ). Call xEncoder.ProcessFile(sEncodedFile(i), 0, 0, bfpDecode, (i = nNbEncodedFile - 1), sDecodeFolder & sDecodedFileName, (i <> 0), lBytesRead) If Len(sDecodedFileName) = 0 Then 'No file name was specified by the user. Read the one used by default 'by the encoding library (set at the first call). sDecodedFileName = xEncoder.EncodingFormat.HeaderFilename End If 'Keep the eventual error code and description as it is reset by the 'On error goto 0 lErrNumber = Err.Number sErrDesc = Err.Description On Error GoTo 0 If lErrNumber <> 0 Then 'Display the error that occured DecodeFile = False txtMessage = txtMessage & sEncodedFile(i) & " fail to decode" & vbCrLf & vbCrLf & _ sErrDesc & " (" & Hex(lErrNumber) & ")" & vbCrLf Exit For Else 'Display a message of success txtMessage = txtMessage & sEncodedFile(i) & " successfully decoded in " & sDecodeFolder & sDecodedFileName & vbCrLf End If Next End If End If 'Deallocate the Encoding object. The encoding object will free 'the EncodingFormat object. Set xEncoder = Nothing Me.MousePointer = vbDefault End Function '==================================================================================== 'Functions - others '==================================================================================== '------------------------------------------------------------------------------------ 'Create a new instance of an encoding format according to the specified 'encoding method. 'Set some properties to the encoding format object appropriate for the selected 'encoding method. '------------------------------------------------------------------------------------ Private Function CreateEncodingFormat(ByVal eMethod As enuEncodingMethod, _ ByRef xEncoder As XceedBinaryEncoding) As Boolean Dim bCreateOK As Boolean bCreateOK = True 'We instanciate a new encoding format, assigning it directly to the 'EncodingFormat property of the XceedBinaryEncoding object. 'The drawbacks to this programming method are : ' - we don't have access to the code completion for the EncodingFormat ' - setting a property of the EncodingFormat (a VB Object, or COM ' IDispatch) will use the QueryInterface COM scheme which is less ' efficient than calling a property from a object of type ' XceedBase64EncodingFormat for instance. 'To see an example of how it could be done more efficiently and with the 'help of code completion, consult the MemoryEncode sample application. On Error Resume Next Select Case eMethod Case emBase64 Set xEncoder.EncodingFormat = New XceedBase64EncodingFormat Case emBinHex Set xEncoder.EncodingFormat = New XceedBinHexEncodingFormat 'When encoding, we want the output file to have BinHex formating. 'When decoding, we tell to the Encoder that the input file have 'BinHex formating xEncoder.EncodingFormat.IncludeHeaderFooter = True Case emHexadecimal Set xEncoder.EncodingFormat = New XceedHexaEncodingFormat Case emQuotedPrintable Set xEncoder.EncodingFormat = New XceedQuotedPrintableEncodingFormat Case emUUEncode Set xEncoder.EncodingFormat = New XceedUUEncodingFormat 'When encoding, we want the output file to have a header/footer. 'When decoding, we tell to the Encoder that the input file have 'a header/footer xEncoder.EncodingFormat.IncludeHeaderFooter = True Case emXXEncode Set xEncoder.EncodingFormat = New XceedXXEncodingFormat 'When encoding, we want the output file to have a header/footer. 'When decoding, we tell to the Encoder that the input file have 'a header/footer xEncoder.EncodingFormat.IncludeHeaderFooter = True End Select If Err.Number <> 0 Then txtMessage = txtMessage & " error initializing the encoding format" & vbCrLf & vbCrLf & _ Err.Description & " (" & Hex(Err.Number) & ")" & vbCrLf bCreateOK = False End If On Error GoTo 0 CreateEncodingFormat = bCreateOK End Function '------------------------------------------------------------------------------------ 'Return the file name part from a "path and file name" string '------------------------------------------------------------------------------------ Private Function ExtractFileName(ByVal sFilename As String) As String Dim i As Integer Dim nFileNameLen As Integer Dim nLenToTake As Integer nFileNameLen = Len(sFilename) i = nFileNameLen nLenToTake = -1 'Starting from the end of the string, we check each character and stop 'at the first occurence of \ or : While i > 0 And nLenToTake = -1 Select Case Mid(sFilename, i, 1) Case "\", ":" 'The length of the file name part is the length of the string 'minus the position of the \ or : nLenToTake = nFileNameLen - i End Select i = i - 1 Wend If nLenToTake = -1 Then 'No \ or : were present. We assume that the string was a file name and 'we return it ExtractFileName = sFilename Else 'We return the right part of the string corresponding to the file name ExtractFileName = Right(sFilename, nLenToTake) End If End Function '------------------------------------------------------------------------------------ 'Return the folder part from a "path and file name" string excluding any 'terminating \ '------------------------------------------------------------------------------------ Private Function ExtractFolder(ByVal sFilename As String) As String Dim i As Integer Dim nFileNameLen As Integer Dim nLenToTake As Integer nFileNameLen = Len(sFilename) i = nFileNameLen nLenToTake = -1 'Starting from the end of the string, we check each character and stop 'at the first occurence of \ or : While i > 0 And nLenToTake = -1 Select Case Mid(sFilename, i, 1) Case "\" 'The length of the folder name part is the position of the \ minus 1 '(to exclude the \) nLenToTake = i - 1 Case ":" 'The length of the folder name part is the same as the position of the : nLenToTake = i End Select i = i - 1 Wend If nLenToTake = -1 Then 'The string contains no folder. We return an empty string ExtractFolder = "" Else 'Return the left part of the string corresponding to the folder name ExtractFolder = Left(sFilename, nLenToTake) End If End Function '------------------------------------------------------------------------------------ 'Return the specified file name WITHOUT its extension, if any. '------------------------------------------------------------------------------------ Private Function RemoveFileExtension(ByVal sFilename As String) As String Dim i As Integer Dim nFileNameLen As Integer Dim nLenToTake As Integer nFileNameLen = Len(sFilename) i = nFileNameLen nLenToTake = -1 'Starting from the end of the string, we check each character and stop 'at the first occurence of . or \ While i > 0 And nLenToTake = -1 Select Case Mid(sFilename, i, 1) Case "." 'The length of the filename name part is the position of the . minus 1 '(to exclude the .) nLenToTake = i - 1 Case "\" 'The file name contains a path. Returns all the string nLenToTake = nFileNameLen End Select i = i - 1 Wend If nLenToTake = -1 Then 'No extension was found return an empty string RemoveFileExtension = "" Else RemoveFileExtension = Left(sFilename, nLenToTake) End If End Function '------------------------------------------------------------------------------------ 'Return the extension part of the specified file name '------------------------------------------------------------------------------------ Private Function ExtractFileExtension(ByVal sFilename As String) As String Dim i As Integer Dim nFileNameLen As Integer Dim nLenToTake As Integer nFileNameLen = Len(sFilename) i = nFileNameLen nLenToTake = -1 'Starting from the end of the string, we check each character and stop 'at the first occurence of . or \ While i > 0 And nLenToTake = -1 Select Case Mid(sFilename, i, 1) Case "." 'The length of the extension part is the length of the string 'minus the position of the . nLenToTake = nFileNameLen - i Case "\" 'No extension was found. We will return an empty string nLenToTake = 0 End Select i = i - 1 Wend If nLenToTake = -1 Then 'No extension was found. We return an empty string ExtractFileExtension = "" Else ExtractFileExtension = Right(sFilename, nLenToTake) End If End Function '------------------------------------------------------------------------------------ 'Return the extension associated with the specified encoding method '------------------------------------------------------------------------------------ Private Function StdFileExtension(eMethod As enuEncodingMethod) As String StdFileExtension = "" Select Case eMethod Case emUUEncode StdFileExtension = ".uue" Case emXXEncode StdFileExtension = ".xxe" Case emBase64 StdFileExtension = ".b64" Case emHexadecimal StdFileExtension = ".hex" Case emQuotedPrintable StdFileExtension = ".qpr" Case emBinHex StdFileExtension = ".hqx" End Select End Function '------------------------------------------------------------------------------------ 'Read the last saved options kept in the registry '------------------------------------------------------------------------------------ Private Sub LoadOption() ' Encoding option m_lMaxLineLength = Val(GetSetting("XceedEncodingManager", "Encoding", "MaxLineLen", "78")) If UCase(GetSetting("XceedEncodingManager", "Encoding", "EOLType", "CRLF")) = "LF" Then m_eEndOfLineType = bltLf Else m_eEndOfLineType = bltCrLf End If ' Decoding option m_bContinueOnInvalidData = CBool(Val(GetSetting("XceedEncodingManager", "Decoding", "ContinueOnInvalidData", "-1"))) End Sub '------------------------------------------------------------------------------------ 'Save the current options in the registry '------------------------------------------------------------------------------------ Private Sub SaveOption() Dim sTemp As String ' Encoding option Call SaveSetting("XceedEncodingManager", "Encoding", "MaxLineLen", Str(m_lMaxLineLength)) If m_eEndOfLineType = bltLf Then sTemp = "LF" Else sTemp = "CRLF" End If Call SaveSetting("XceedEncodingManager", "Encoding", "EOLType", sTemp) ' Decoding option If m_bContinueOnInvalidData Then sTemp = "-1" Else sTemp = "0" End If Call SaveSetting("XceedEncodingManager", "Decoding", "ContinueOnInvalidData", sTemp) End Sub 
(.txt)