Results 1 to 22 of 22

Thread: Http Uploading files to server

  1. #1

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Http Uploading files to server

    Somehow I have changed correct to code for the worse ... again ... after it worked perfectly.

    These are my present routines:

    On the client side:

    Code:
        'upload file
        FileOffset = 1
        If FileSizeBytes > 3500000 Then BufferSize = 3500000 Else BufferSize = FileSizeBytes
        
        FNr = FreeFile(0)
        Open LocalFileAndPathName For Binary As FNr
        Do While BufferSize > 0
            ReDim ByteArray(0 To BufferSize - 1)
            Get FNr, FileOffset, ByteArray
            'Stop
            Set Rs = RPC.DoRPC("UploadFileContent", ServerFilename, ByteArray, BufferSize, FileSizeBytes)
            'If IsNumeric(Rs(0)) Then SaveFileOnServer = False: Exit Function
            If Rs(0) < BufferSize Then SaveFileOnServer = False: Exit Function
            If Rs(0) = FileSizeBytes Then SaveFileOnServer = True: Exit Function
            AlreadyDownLoaded = AlreadyDownLoaded + BufferSize
            FileOffset = AlreadyDownLoaded + 1
            BytesLeft = FileSizeBytes - AlreadyDownLoaded
            If BytesLeft <= 0 Then Exit Do
            If BytesLeft < 3500000 Then BufferSize = BytesLeft Else BufferSize = 3500000
            If FileOffset >= FileSizeBytes Then Exit Do
            If BytesLeft <= 0 Then Exit Do
        Loop
        Close
    And on the server side:

    Code:
    'does the folder exist?
    FolderAndFileName = Replace(App.Path & "\" & RsIn(1), "\", "/")
    LastBackSlash = InStrRev(FolderAndFileName, "/")
    FolderName = Left(FolderAndFileName, LastBackSlash - 1)
    FolderExists = fso.FolderExists(FolderName)
    If FolderExists = False Then GoSub FolderExistNot           'make this folder and all the folders in between as well
    
    ByteArray = RsIn(2)
    BufferSize = RsIn(3)
    ReDim ByteArray(0 To BufferSize - 1)
    OriginalSizeBytes = RsIn(4)
    
    'does the file or part of it already exist
    If fso.FileExists(FolderAndFileName) Then
        Set File = fso.GetFile(FolderAndFileName)
        PresentSizeBytes = File.Size
        If PresentSizeBytes < OriginalSizeBytes Then
            FNr = FreeFile(0)
            Open FolderAndFileName For Binary As FNr
            Put FNr, PresentSizeBytes + 1, ByteArray
            Close FNr
        Else
            UploadedByteSize = File.Size
            Set RsOut = CreateResultRs("UploadFileContent", UploadedByteSize): Exit Sub
        End If
    Else
        FNr = FreeFile(0)
        Open FolderAndFileName For Binary As FNr
        Put FNr, 1, ByteArray
        Close FNr
    End If
    
    Set File = fso.GetFile(FolderAndFileName)
    UploadedByteSize = File.Size
    Set RsOut = CreateResultRs("UploadFileContent", UploadedByteSize): Exit Sub
    Although these routines work fine with no errors and the 3.5MB limit is being handled, the file uploaded is corrupted for any file size uploaded.
    On the server explorer it gives the correct uploaded file size for the file, but I must have made an error somewhere which I cannot find.

  2. #2

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Removed.
    Last edited by Peekay; Oct 27th, 2019 at 12:06 PM.

  3. #3
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Http Uploading files to server

    I already gave a hint, to throw out these old VB-FileOps -
    and to change them to modern (Unicode-capable) ones (as e.g. implemented in the RC5-FSO-Object).

    Also - all these "Monster-Routines" (longer than 20 lines) have to go.
    (they are Error-prone, due to their size alone).

    For a "chunkbased Upload- or also Download" you should not have much more Code than in this Test-Forms UploadRoutineSimulation()-Sub:
    Code:
    Option Explicit
    Private Sub Form_Load()
      Const ClientFile As String = "C:\temp\ClientFile.txt"
      Const ServerFile As String = "C:\temp\ServerFile.txt"
      
      On Error GoTo 1
      WriteTextContent ClientFile, "ABC" 'Test-File-Len = 3
     
      If FileExists(ServerFile) Then DeleteFile ServerFile
      UploadRoutineSimulation ClientFile, ServerFile, 2 '<- Test-Chunksize = 2
      
    1 If Err Then
         MsgBox "Something went wrong: " & Err.Description
      ElseIf FileLen(ClientFile) <> FileLen(ServerFile) Then
         MsgBox "Something went wrong (the FileLen differs)"
      ElseIf GetFileHash(ClientFile) <> GetFileHash(ServerFile) Then
         MsgBox "Something went wrong (the SHA1Hash differs)"
      End If
    End Sub
     
    Sub UploadRoutineSimulation(ClientFile$, ServerFile$, Optional ByVal ChunkSize& = 2 ^ 19)
      Dim B() As Byte, Offs As Currency, BytesRead As Long
      Do
        B = "": Offs = Offs + BytesRead 'reset B to zero-length bytecontent...
        ReadChunk ClientFile, B, Offs, ChunkSize '...before trying to read a new chunk into B
        BytesRead = UBound(B) + 1 '<- better to determine this directly from the returned B-Container
        
        AppendChunk ServerFile, B '<- because B is what's passed to the serverside next
      Loop While BytesRead
    End Sub
    The above code is using a handful of very short Helper-Routines (all sitting in a *.bas-File, named modFileOps):
    Code:
    Option Explicit
    
    Function FileExists(FileName As String) As Boolean
      FileExists = New_c.FSO.FileExists(FileName)
    End Function
    Function GetFileLen(FileName As String) As Currency
      GetFileLen = New_c.FSO.FileLen(FileName)
    End Function
    Function GetFileHash(FileName As String) As String
      GetFileHash = New_c.FSO.GetFileHash(FileName, CALG_SHA1)
    End Function
    
    Sub WriteTextContent(FileName As String, Text As String)
      New_c.FSO.WriteTextContent FileName, Text, True
    End Sub
    
    Sub DeleteFile(FileName As String)
      New_c.FSO.DeleteFile FileName
    End Sub
    
    Sub ReadChunk(FileName As String, B() As Byte, Offset, ChunkSize)
      Dim S As cStream
      Set S = New_c.FSO.OpenFileStream(FileName, STRM_READ Or STRM_SHARE_DENY_NONE)
          S.SetPosition Offset
          S.ReadToByteArr B, ChunkSize
    End Sub
    
    Sub AppendChunk(FileName As String, B() As Byte)
      Dim S As cStream
      Set S = New_c.FSO.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
          S.SetPosition 0, STRM_SeekFromEnd
          S.WriteFromByteArr B
    End Sub
    The Form-TestCode further above will work already (by using this new modFileOps.bas-module).
    Try to uderstand and get familiar with it "as it is" - in an isolated Form-Test-Project first.

    Then, to integrate it into your Remote-scenario -
    this Helper-Bas-Module will have to be included on both ends (your Client- and the Server-side VB-Projects).

    After that Helper-Bas-Module exists in both Projects, you will have to:
    -> 1) add an additional clientside Module, named modFileOpsRPC.bas (adding similarly named Wrapper-Routines there)
    -> 2) add appropriate Sub-Routines (also similarly named) into your serverside cHandler.cls

    Now - the only thing remaining is, to implement (in both new Modules: modFileOpsRPC.bas and cHandler.cls) -
    appropriate wrapper-routines.

    Example for the FileExists-Routine, which is contained (on both ends, via modFileOps.bas)

    At the clientside, the similarly named RPC-Wrapper-routine (in modFileOpsRPC.bas) would look this way:
    Code:
    Function FileExists(FileName As String) As Boolean
      Dim RsResult As ADODB.Recordset: Set RsResult = RPC.DoRPC("FileExists", FileName)
      
      If NoErrorIn(RsResult) Then FileExists = RsResult(0)
    End Function
    And at the serverside, the cHandler.cls would get the appropriate addition:
    Code:
    Sub FileExists()
      Dim FileName As String: FileName = RsIn(1).Value 
      
      Set RsOut = CreateResultRs("Result", modFileOps.FileExists(FileName))
    End Sub
    As said, writing such "wrapping-pairs" will have to be repeated for any of the Routines in modFileOps.bas
    (shouldn't be that hard to do - just double-check for potential copy&paste mistakes in the names and Params,
    which might happen when you use the clipboard to "replicate similar wrapper-routines").

    HTH

    Olaf
    Last edited by Schmidt; Oct 27th, 2019 at 03:29 PM.

  4. #4
    PowerPoster
    Join Date
    Nov 2017
    Posts
    3,116

    Re: Http Uploading files to server

    Quote Originally Posted by Peekay View Post
    Somehow I have changed correct to code for the worse ... again ... after it worked perfectly.
    The solution to this is to restore your code from a point in time prior to you making this change. The fact that you are posting this issue here leads me to believe you don't have backups of your code. If that is the case, that is something that you need to rectify immediately. Even if it is to just make a copy of your main projects every day to a date specific folder on a thumb drive, that is better than nothing.

  5. #5

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Olaf,

    Thanks for this code, which is all I need, but was unaware of. It will take me some time for me to assimilate and implement.

    OptionBase1,
    I have at least one external and one internal backup being done constantly, but I was unaware that OneDrive, which I use, kept older versions of about 2 months or more. I had thought that they only keep the last synced version.

    PK

  6. #6

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Olaf,

    FileExists = New_c.FSO.FileExists(FileName)
    I am not sure what this New_c refers to.
    Does this refer to a program/project reference, an API, a class or to the Scripting dictionary?
    I have read some on the CryptoAPI, but that is still Greek to me. I have no knowledge of encryption.

    Thanks
    PK

  7. #7
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Http Uploading files to server

    Quote Originally Posted by Peekay View Post
    I am not sure what this New_c refers to.
    Does this refer to a program/project reference, ...
    Yes, it is related to the (still missing) Project-Reference of vbRichClient5(.dll).
    New_c is a constructor-Object, which is then "automatically there" as soon as this project-reference was ensured.

    You will need to install (register via regsvr32) the RichClient5-BaseDlls on your Clients,
    as well as on your Server-machine, before trying to set this reference in your client- and server-projects.

    The downloads for that are on vbRichClient.com.

    Olaf

  8. #8
    PowerPoster
    Join Date
    Feb 2012
    Location
    West Virginia
    Posts
    14,205

    Re: Http Uploading files to server

    I have a program here that has the option to transfer files. I use the native VB file binary i/o and it works perfectly fine, No need for FSO or any third party tool or utility.

    I really have no idea what FSO may do in such a case as I never use it in VB. I have used it in the past in EVB as that was the only option but in VB the native file i/o and related functions have always worked well for me.

  9. #9

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    DataMiser,

    May I have a look at your code?

    PK

  10. #10
    PowerPoster
    Join Date
    Feb 2012
    Location
    West Virginia
    Posts
    14,205

    Re: Http Uploading files to server

    Quote Originally Posted by Peekay View Post
    DataMiser,

    May I have a look at your code?

    PK
    Sorry, the code I refer to is part of a commercial product and can't be posted, the server is written in VB6 and the client is written in VB.Net.

  11. #11

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Olaf,

    I find it difficult to interpret the parameters of the methods of the vbRichClient and I cannot find an explanation of what they refer to other than reading their names in the routines and functions.
    For instance I need to supply values for this:

    Code:
    Set S = New_c.fso.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
    and I do not know what the latter two values refer to which I should supply, or should I just leave it as it is?

    Thanks
    PK
    Last edited by Peekay; Oct 31st, 2019 at 07:11 AM.

  12. #12
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Http Uploading files to server

    Quote Originally Posted by Peekay View Post
    For instance I need to supply values for this:

    Code:
    Set S = New_c.fso.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
    No, you don't need to supply values for this...
    I wrote quite clearly further above already, that your "interface-functions" are all in modFileOps.bas,
    which kind of "hides" the RC5-FSO-Object from your other code.

    All you have to provide (regarding RPC-parameters in File-Write-Direction) -
    is therefore reduced to the two parameters I've marked in blue below:

    Code:
    Sub AppendChunk(FileName As String, B() As Byte)
      Dim S As cStream
      Set S = New_c.FSO.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
          S.SetPosition 0, STRM_SeekFromEnd
          S.WriteFromByteArr B
    End Sub
    Quote Originally Posted by Peekay View Post
    ...and I do not know what the latter two values refer to which I should supply.
    As said, the latter two parameters of FSO.OpenFileStream are not to be supplied by you.
    But their meaning is described by their names (which intellisense should have shown you):
    - FileName: obviously the FileName of the File you're about to open as a Stream
    - Flags: a combination of AccessRight- and Behaviour-EnumValues which any FileOpen/Create-API offers
    - OpenAlways: an optional Boolean-Param, which when left out (or at False) will make OpenFileStream throw an error, when the File does not exist

    Since you're apparently unfamiliar with File-Flags - I guess it's a good thing, that I've left them out of the Routine AppendChunk -
    which as said, is one of the 6 Routines in modFileOps.base, you'll have to make RPC-capable.

    Here are the 6 routines (and their parameters) of modFileOps.bas again, you'll have to to write RPC-Wrapper-Functions for:

    Function FileExists(FileName As String) As Boolean
    Function GetFileLen(FileName As String) As Currency
    Function GetFileHash(FileName As String) As String

    Sub DeleteFile(FileName As String)
    Sub AppendChunk(FileName As String, B() As Byte)
    Sub ReadChunk(FileName As String, B() As Byte, Offset, ChunkSize)

    In my first post #3, I've implemented the needed wrapper-pair for the FileExists-routine already as an example for you.

    Please post your wrapper-pairs for the remaining 5 routines, before we proceed here...
    (each part of a pair will have to go - as already mentioned in post #3 - into a new modFileOpsRPC.bas and into cHandler.cls later).

    @DataMiser:
    When you write the following: "I use the native VB file binary i/o and it works perfectly fine..."
    then you're deluding yourself - and are misleading others, because that's just plain wrong
    (since these old VBRuntime-Functions are fare from "perfectly fine").

    VB6 old File-Functionality is:
    - error-prone in the way it deals with FileHandles
    - it does not support UniCode (in the FileNames, and in the Text-Write and -Read-functions)
    - it is limited to Files < 2GB (the FileLen-Function, as well as the FileOffsets are limited to 2GB)
    - it does not support the calculation of FileHashes

    Olaf

  13. #13

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Olaf, For what it's worth this is what I am testing now:

    On my client side I firstly have this:

    Code:
    Public Sub UploadRoutine(ClientFile$, ServerFile$, Optional ByVal ChunkSize& = 2 ^ 19)
        Dim B() As Byte, Offs As Currency, BytesRead As Long
        Do
            B = "": Offs = Offs + BytesRead
            modFileOps.ReadChunk ClientFile, B, Offs, ChunkSize
            BytesRead = UBound(B) + 1
            'AppendChunk ServerFile, B
            modFileOpsRPC.AppendChunk ServerFile, B
        Loop While BytesRead
        Exit Sub
    
    End Sub
    It does not give me an error.
    Might I ask if your chunks are allowed to be 2^19 long? I have set it to 3 500 000.

    It then goes to my client routine in modFileOps which I quote here fully untested and which module I also have on the server side:

    Code:
    Option Explicit
    Function FileExists(FileName As String) As Boolean
        FileExists = New_c.fso.FileExists(FileName)
    End Function
    
    Function GetFileLen(FileName As String) As Currency
        GetFileLen = New_c.fso.FileLen(FileName)
    End Function
    
    Function GetFileHash(FileName As String) As String
        GetFileHash = New_c.fso.GetFileHash(FileName, CALG_SHA1)
    End Function
    
    Sub WriteTextContent(FileName As String, Text As String)
        New_c.fso.WriteTextContent FileName, Text, True
    End Sub
    
    Sub DeleteFile(FileName As String)
        New_c.fso.DeleteFile FileName
    End Sub
    
    Sub ReadChunk(FileName As String, B() As Byte, Offset, ChunkSize)
        Dim S As cStream
        Set S = New_c.fso.OpenFileStream(FileName, STRM_READ Or STRM_SHARE_DENY_NONE)
        S.SetPosition Offset
        S.ReadToByteArr B, ChunkSize
    End Sub
    
    Sub AppendChunk(FileName As String, B() As Byte)
        Dim S As cStream
        Set S = New_c.fso.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
        S.SetPosition 0, STRM_SeekFromEnd
        S.WriteFromByteArr B
    End Sub
    
    Sub CreateDirectory(FolderName As String)
        New_c.fso.CreateDirectory FileName
    End Sub
    
    Function DirectoryHasSubDirs(FolderName As String) As Boolean
        New_c.fso.DirectoryHasSubDirs FolderName
    End Function
    
    Function FolderExists(FolderName As String) As Boolean
        New_c.fso.FolderExists FolderName
    End Function
    
    Sub GetDirList(FolderName As String)
        New_c.fso.GetDirList FolderName
    End Sub
    
    Function GetFileNameFromFullPath(PathName As String) As String
        New_c.fso.GetFileNameFromFullPath PathName
    End Function
    
    Function GetPathNameFromFullPath(PathName As String) As String
        New_c.fso.GetPathNameFromFullPath PathName
    End Function
    
    Function IsFileWriteable(FileName As String) As Boolean
        New_c.fso.GetPathNameFromFullPath PathName
    End Function
    
    Sub MoveFile(FileName As String)
        New_c.fso.MoveFile FileName
    End Sub
    The ReadChunk does not give me any errors.

    It then goes to the modFileOpsRPC which is like this:

    Code:
    Function ReadChunk(FileName As String, B() As Byte, Offset, ChunkSize)
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("ReadChunk", FileName, B, Offset, ChunkSize)
        If NoErrorIn(RsResult) Then ReadChunk = RsResult(0)
    End Function
    It does not give me any errors

    I get an error in the cHandler on the server side:

    Code:
    Sub AppendChunk()
        Dim FileName As String, B() As Byte
        FileName = RsIn(1).Value
        B = RsIn(2).Value
        
        
        Set RsOut = CreateResultRs("Result", modFileOps.AppendChunk(Replace(App.Path & "/" & RsIn(1), "\", "/"), B))
    End Sub
    It does not like the .appendchunk method which should send it to this routine on the serverside modFileOps:

    Code:
    Sub AppendChunk(FileName As String, B() As Byte)
        Dim S As cStream
        Set S = New_c.fso.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
        S.SetPosition 0, STRM_SeekFromEnd
        S.WriteFromByteArr B
    End Sub
    PK

  14. #14
    PowerPoster
    Join Date
    Nov 2017
    Posts
    3,116

    Re: Http Uploading files to server

    Quote Originally Posted by Peekay View Post
    Olaf,

    Thanks for this code, which is all I need, but was unaware of. It will take me some time for me to assimilate and implement.

    OptionBase1,
    I have at least one external and one internal backup being done constantly, but I was unaware that OneDrive, which I use, kept older versions of about 2 months or more. I had thought that they only keep the last synced version.

    PK
    So why can't you just restore your code from backup then if it was working fine before you made changes and broke it?

  15. #15
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Http Uploading files to server

    Quote Originally Posted by Peekay View Post
    Olaf, For what it's worth this is what I am testing now:

    On my client side I firstly have this:

    Code:
    Public Sub UploadRoutine(ClientFile$, ServerFile$, Optional ByVal ChunkSize& = 2 ^ 19)
        Dim B() As Byte, Offs As Currency, BytesRead As Long
        Do
            B = "": Offs = Offs + BytesRead
            modFileOps.ReadChunk ClientFile, B, Offs, ChunkSize
            BytesRead = UBound(B) + 1
            'AppendChunk ServerFile, B
            modFileOpsRPC.AppendChunk ServerFile, B
        Loop While BytesRead
        Exit Sub
    
    End Sub
    Before we dive into the chunked Upload- (or Download-) routines themselves,
    could we first validate the following modules:

    Please post the entire contents of your current:
    1. modFileOps.bas (which should reside on the serverside and the clientside)
    2. modFileOpsRPC.bas (which should reside only at the clientside)
    3. cHandler.cls (at least the routines which are the serverside counterparts to the routines in modFileOpsRPC.bas)

    BTW, you've still copy&paste errors in your posted modFileOps.bas (in routines CreateDirectory and IsFileWritable).

    Please make sure, that no such errors are contained in the modules, when you post them.

    Olaf

  16. #16

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Quote Originally Posted by OptionBase1 View Post
    So why can't you just restore your code from backup then if it was working fine before you made changes and broke it?
    I could do that, but it seems to me that Olaf has a much more robust routine than I had. So I will gladly yield to experts - and I would yield to your advice as well. That is why I am here and that is why I engaged with you as well. I appreciate any piece of advice, as I work alone and not in a programming group, community or environment.

    PK

  17. #17

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Olaf,

    I am almost too scared to publish, but here it is .. and no doubt it contains errors:

    This is my modFileOps which I have included on the client and the server side:

    Code:
    Option Explicit
    Function FileExists(FileName As String) As Boolean
        On Error GoTo ErrorHandler
        FileExists = New_c.fso.FileExists(FileName): Exit Function
        On Error GoTo 0
        Exit Function
        
    ErrorHandler:
        Exit Function
        
    End Function
    
    Function GetFileLen(FileName As String) As Currency
        On Error GoTo ErrorHandler
        GetFileLen = New_c.fso.FileLen(FileName): Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        GetFileLen = 0
        Exit Function
    
    End Function
    
    Function GetFileHash(FileName As String) As String
        On Error GoTo ErrorHandler
        GetFileHash = New_c.fso.GetFileHash(FileName, CALG_SHA1): Exit Function
        On Error GoTo 0
        Exit Function
        
    ErrorHandler:
        GetFileHash = Error
        Exit Function
        
    End Function
    
    Function WriteTextContent(FileName As String, Text As String) As Boolean
        On Error GoTo ErrorHandler
        New_c.fso.WriteTextContent FileName, Text, True: WriteTextContent = True: Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    
    End Function
    
    Function DeleteFile(FileName As String) As Boolean
        On Error GoTo ErrorHandler
        New_c.fso.DeleteFile FileName: DeleteFile = True: Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    
    End Function
    
    Function ReadChunk(FileName As String, B() As Byte, Offset, ChunkSize) As Byte()
        Dim S As cStream
        On Error GoTo ErrorHandler
        Set S = New_c.fso.OpenFileStream(FileName, STRM_READ Or STRM_SHARE_DENY_NONE)
        S.SetPosition Offset
        S.ReadToByteArr B, ChunkSize
        ReadChunk = B: Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    
    End Function
    
    Function AppendChunk(FileName As String, B() As Byte) As Boolean
        Dim S As cStream
        On Error GoTo ErrorHandler
        Set S = New_c.fso.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
        S.SetPosition 0, STRM_SeekFromEnd
        S.WriteFromByteArr B
        AppendChunk = True: Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    
    End Function
    
    Function CreateDirectory(FolderName As String) As Boolean
        On Error GoTo ErrorHandler
        New_c.fso.CreateDirectory FolderName: CreateDirectory = True: Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    
    End Function
    
    Function DirectoryHasSubDirs(FolderName As String) As Boolean
        On Error GoTo ErrorHandler
        DirectoryHasSubDirs = New_c.fso.DirectoryHasSubDirs(FolderName): Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    End Function
    
    Function FolderExists(FolderName As String) As Boolean
        On Error GoTo ErrorHandler
        FolderExists = New_c.fso.FolderExists(FolderName): Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
        
    End Function
    
    Function GetDirList(FolderName As String) As ADODB.Recordset
        Rs As ADODB.Recordset
        On Error GoTo ErrorHandler
        Set GetDirList = New_c.fso.GetDirList(FolderName): Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Set GetDirList = Error
        Exit Function
        
    End Function
    
    Function GetFileNameFromFullPath(PathName As String) As String
        On Error GoTo ErrorHandler
        GetFileNameFromFullPath = New_c.fso.GetFileNameFromFullPath(PathName): Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        GetFileNameFromFullPath = Error
        Exit Function
    
    End Function
    
    Function GetPathNameFromFullPath(PathName As String) As String
        On Error GoTo ErrorHandler
        GetPathNameFromFullPath = New_c.fso.GetPathNameFromFullPath(PathName): Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        GetPathNameFromFullPath = Error
        Exit Function
       
        
    End Function
    
    Function IsFileWriteable(FileName As String) As Boolean
        On Error GoTo ErrorHandler
        IsFileWriteable = New_c.fso.IsFileWritable(FileName): Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    
    End Function
    
    Function MoveFile(OldFileName As String, NewFileName As String) As Boolean
        On Error GoTo ErrorHandler
        New_c.fso.MoveFile OldFileName, NewFileName: MoveFile = True: Exit Function
        On Error GoTo 0
        Exit Function
    
    ErrorHandler:
        Exit Function
    End Function
    Here is my modFileOpsRPC only used on the client side:

    Code:
    Option Explicit
    
    Function FileExists(FileName As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("FileExists", FileName)
        If NoErrorIn(RsResult) Then FileExists = RsResult(0)
    End Function
    
    Function GetFileLen(FileName As String) As Currency
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("GetFileLen", FileName)
        If NoErrorIn(RsResult) Then GetFileLen = RsResult(0)
    End Function
    
    Function GetFileHash(FileName As String) As String
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("GetFileHash", FileName)
        If NoErrorIn(RsResult) Then GetFileHash = RsResult(0)
    End Function
    
    Function WriteTextContent(FileName As String, Text As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("WriteTextContent", FileName, Text)
        If NoErrorIn(RsResult) Then WriteTextContent = RsResult(0)
    End Function
    
    Function DeleteFile(FileName As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("DeleteFile", FileName)
        If NoErrorIn(RsResult) Then DeleteFile = RsResult(0)
    End Function
    
    Function ReadChunk(FileName As String, B() As Byte, Offset, ChunkSize) As Long
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("ReadChunk", FileName, B(), Offset, ChunkSize)
        If NoErrorIn(RsResult) Then ReadChunk = RsResult(0)
    End Function
    
    Function AppendChunk(FileName As String, B() As Byte) As Long
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("AppendChunk", FileName, B)
        If NoErrorIn(RsResult) Then AppendChunk = RsResult(0)
    End Function
    
    Function CreateDirectory(FolderName As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("CreateDirectory", FolderName)
        If NoErrorIn(RsResult) Then CreateDirectory = RsResult(0)
    End Function
    
    Function FolderExists(FolderName As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("FolderExists", FolderName)
        If NoErrorIn(RsResult) Then FolderExists = RsResult(0)
    End Function
    
    Function DirectoryHasSubDirs(FolderName As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("DirectoryHasSubDirs", FolderName)
        If NoErrorIn(RsResult) Then DirectoryHasSubDirs = RsResult(0)
    End Function
    
    'I wish I had DirectoryHasSubDirsOrFiles' or 'FolderIsEmpty'
    
    Function GetDirList(FolderName As String) As ADODB.Recordset
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("GetDirList", FolderName)
        If NoErrorIn(RsResult) Then GetDirList = RsResult(0)
    End Function
    
    Function GetFileNameFromFullPath(FullPathName As String) As String
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("GetFileNameFromFullPath", FullPathName)
        If NoErrorIn(RsResult) Then GetFileNameFromFullPath = RsResult(0)
    End Function
    
    Function GetPathNameFromFullPath(FullPathName As String) As String
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("GetPathNameFromFullPath", FullPathName)
        If NoErrorIn(RsResult) Then GetPathNameFromFullPath = RsResult(0)
    End Function
    
    Function IsFileWriteable(FileName As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("IsFileWriteable", FileName)
        If NoErrorIn(RsResult) Then IsFileWriteable = RsResult(0)
    End Function
    
    Function MoveFile(FileName As String, OldFolder As String, NewFolder As String) As Boolean
        Dim RsResult As ADODB.Recordset
        Set RsResult = RPC.DoRPC("MoveFile", OldFolder, NewFolder)
        If NoErrorIn(RsResult) Then MoveFile = RsResult(0)
    End Function
    Here is my cHandler class on the server side:

    Code:
    Sub FileExists()
        Set RsOut = CreateResultRs("FileExists", modFileOps.FileExists(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub GetFileLen()
        Set RsOut = CreateResultRs("GetFileLen", modFileOps.GetFileLen(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub GetFileHash()
        Set RsOut = CreateResultRs("GetFileHash", modFileOps.GetFileHash(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub WriteTextContent()
        Set RsOut = CreateResultRs("WriteTextContent", modFileOps.WriteTextContent(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub DeleteFile()
        Set RsOut = CreateResultRs("DeleteFile", modFileOps.DeleteFile(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub DeleteFile()
        Set RsOut = CreateResultRs("DeleteFile", modFileOps.DeleteFile(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub ReadChunk()
        Set RsOut = CreateResultRs("ReadChunk", modFileOps.ReadChunk(Replace(App.Path & "/" & RsIn(1), "\", "/"), RsIn(2), RsIn(3), RsIn(4)))
    End Sub
    
    Sub AppendChunk()
        Set RsOut = CreateResultRs("AppendChunk", modFileOps.AppendChunk(Replace(App.Path & "/" & RsIn(1), "\", "/"), RsIn(2)))
    End Sub
    
    Sub CreateDirectory()
        Set RsOut = CreateResultRs("CreateDirectory", modFileOps.CreateDirectory(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub DirectoryHasSubDirs()
        Set RsOut = CreateResultRs("DirectoryHasSubDirs", modFileOps.DirectoryHasSubDirs(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    'I wish I had DirectoryHasSubDirsOrFiles' or 'FolderIsEmpty'
    
    Sub FolderExists()
        Set RsOut = CreateResultRs("FolderExists", modFileOps.FolderExists(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub GetDirList()
        Set RsOut = CreateResultRs("GetDirList", modFileOps.GetDirList(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub GetFileNameFromFullPath()
        Set RsOut = CreateResultRs("GetFileNameFromFullPath", modFileOps.GetFileNameFromFullPath(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub GetPathNameFromFullPath()
        Set RsOut = CreateResultRs("GetPathNameFromFullPath", modFileOps.GetPathNameFromFullPath(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub IsFileWriteable()
        Set RsOut = CreateResultRs("IsFileWriteable", modFileOps.IsFileWriteable(Replace(App.Path & "/" & RsIn(1), "\", "/")))
    End Sub
    
    Sub MoveFile()
        Set RsOut = CreateResultRs("MoveFile", modFileOps.MoveFile(Replace(App.Path & "/" & RsIn(1), "\", "/"), Replace(App.Path & "/" & RsIn(2), "\", "/")))
    End Sub

    PK

  18. #18
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Http Uploading files to server

    Quote Originally Posted by Peekay View Post
    I am almost too scared to publish, but here it is ...
    Well, it was not that bad (aside from the real weird error-handling you've unnecessarily added to the routines in modFileOps.bas)...

    Here is my revised code for the three parts (please take it over into your projects unchanged).

    modFileOps.bas
    Code:
     Option Explicit
     
    Function FileExists(FileName As String) As Boolean
        FileExists = New_c.FSO.FileExists(FileName)
    End Function
    
    Function DeleteFile(FileName As String) As Boolean
        DeleteFile = New_c.FSO.DeleteFile(FileName)
    End Function
    
    Function GetFileLen(FileName As String) As Currency
        GetFileLen = New_c.FSO.FileLen(FileName)
    End Function
    
    Function GetFileHash(FileName As String) As String
        GetFileHash = New_c.FSO.GetFileHash(FileName, CALG_SHA1)
    End Function
    
    Function FolderExists(FolderName As String) As Boolean
        FolderExists = New_c.FSO.FolderExists(FolderName)
    End Function
    
    Function DeleteDirectory(FolderName As String) As Boolean
        DeleteDirectory = New_c.FSO.RemoveDirectory(FolderName)
    End Function
    
    Function CreateDirectory(FolderName As String) As Boolean
        CreateDirectory = New_c.FSO.CreateDirectory(FolderName)
    End Function
    
    Function DirectoryHasSubDirs(FolderName As String) As Boolean
        DirectoryHasSubDirs = New_c.FSO.DirectoryHasSubDirs(FolderName)
    End Function
    
    'both Text-Read/Write-functions are hardwired, to read and write UTF8-content
    Function ReadTextContent(FileName As String) As String
        ReadTextContent = New_c.FSO.ReadTextContent(FileName, False, CP_UTF8)
    End Function
    Function WriteTextContent(FileName As String, Text As String) As Boolean
        New_c.FSO.WriteTextContent FileName, Text, True
        WriteTextContent = True
    End Function
    
    Function ReadChunk(FileName As String, ByVal Offset As Currency, ByVal ChunkSize As Long) As Byte()
        Dim S As cStream
        Set S = New_c.FSO.OpenFileStream(FileName, STRM_READ Or STRM_SHARE_DENY_NONE)
            S.SetPosition Offset
            S.ReadToByteArr ReadChunk, ChunkSize
    End Function
    
    Function AppendChunk(FileName As String, B() As Byte) As Boolean
        Dim S As cStream
        Set S = New_c.FSO.OpenFileStream(FileName, STRM_WRITE Or STRM_SHARE_DENY_NONE, True)
            S.SetPosition 0, STRM_SeekFromEnd
            S.WriteFromByteArr B
        AppendChunk = True
    End Function
    
    Function GetDirList(FolderName As String) As ADODB.Recordset
        Set GetDirList = New ADODB.Recordset 'instantiate the Rs directly into the return-type-functionname
            GetDirList.Fields.Append "Name", vbString
            GetDirList.Fields.Append "IsDirectory", vbBoolean
            GetDirList.Fields.Append "FileSize_Or_HasSubDirs", vbCurrency
            GetDirList.Fields.Append "LastChanged", vbDate
        GetDirList.Open 'open it, after appending the above 4 Fields
            
        With New_c.FSO.GetDirList(FolderName)
          Dim i As Long, ArrFields(): ArrFields = Array(0, 1, 2, 3)
          For i = 0 To .SubDirsCount - 1
            GetDirList.AddNew ArrFields, Array(.SubDirName(i), True, New_c.FSO.DirectoryHasSubDirs(.Path & .SubDirName(i)), .SubDirLastWriteTime(i))
          Next
          For i = 0 To .FilesCount - 1
            GetDirList.AddNew ArrFields, Array(.FileName(i), False, .FileSize(i), .FileLastWriteTime(i))
          Next
        End With
    End Function
    
    Function GetFileNameFromFullPath(PathName As String) As String
        GetFileNameFromFullPath = New_c.FSO.GetFileNameFromFullPath(PathName)
    End Function
    
    Function GetPathNameFromFullPath(PathName As String) As String
        GetPathNameFromFullPath = New_c.FSO.GetPathNameFromFullPath(PathName)
    End Function
    
    Function IsFileWriteable(FileName As String) As Boolean
        IsFileWriteable = New_c.FSO.IsFileWritable(FileName)
    End Function
    
    Function MoveFile(OldFileName As String, NewFileName As String) As Boolean
        MoveFile = New_c.FSO.MoveFile(OldFileName, NewFileName, True)
    End Function
    
    Function MakeServerPath(ByVal RelPath As String) As String
      MakeServerPath = Replace(App.Path & "\" & RelPath, "/", "\")
    End Function
    modFileOpsRPC.bas
    Code:
    Option Explicit
    
    Function FileExists(RelFileName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("FileExists", RelFileName)
      If NoErrorIn(RsResult) Then FileExists = RsResult(0)
    End Function
    
    Function DeleteFile(RelFileName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("DeleteFile", RelFileName)
      If NoErrorIn(RsResult) Then DeleteFile = RsResult(0)
    End Function
    
    Function GetFileLen(RelFileName As String) As Currency
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("GetFileLen", RelFileName)
      If NoErrorIn(RsResult) Then GetFileLen = RsResult(0)
    End Function
     
    Function GetFileHash(RelFileName As String) As String
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("GetFileHash", RelFileName)
      If NoErrorIn(RsResult) Then GetFileHash = RsResult(0)
    End Function
    
    Function FolderExists(RelFolderName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("FolderExists", RelFolderName)
      If NoErrorIn(RsResult) Then FolderExists = RsResult(0)
    End Function
     
    Function DeleteDirectory(RelFolderName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("DeleteDirectory", RelFolderName)
      If NoErrorIn(RsResult) Then DeleteDirectory = RsResult(0)
    End Function
    
    Function CreateDirectory(RelFolderName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("CreateDirectory", RelFolderName)
      If NoErrorIn(RsResult) Then CreateDirectory = RsResult(0)
    End Function
    
    Function DirectoryHasSubDirs(RelFolderName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("DirectoryHasSubDirs", RelFolderName)
      If NoErrorIn(RsResult) Then DirectoryHasSubDirs = RsResult(0)
    End Function
    
    Function ReadTextContent(RelFileName As String) As String
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("ReadTextContent", RelFileName)
      If NoErrorIn(RsResult) Then ReadTextContent = RsResult(0)
    End Function
    
    Function WriteTextContent(RelFileName As String, Text As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("WriteTextContent", RelFileName, Text)
      If NoErrorIn(RsResult) Then WriteTextContent = RsResult(0)
    End Function
    
    Function ReadChunk(RelFileName As String, ByVal Offset As Currency, ByVal ChunkSize As Long) As Byte()
      ReadChunk = "" 'initialize the function-result to an empty ByteArray
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("ReadChunk", RelFileName, Offset, ChunkSize)
      If NoErrorIn(RsResult) Then ReadChunk = RsResult(0)
    End Function
    
    Function AppendChunk(RelFileName As String, B() As Byte) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("AppendChunk", RelFileName, B)
      If NoErrorIn(RsResult) Then AppendChunk = RsResult(0)
    End Function
    
    Function GetDirList(RelFolderName As String) As ADODB.Recordset
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("GetDirList", RelFolderName)
      If NoErrorIn(RsResult) Then Set GetDirList = RsResult
    End Function
     
    Function IsFileWriteable(RelFileName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("IsFileWriteable", RelFileName)
      If NoErrorIn(RsResult) Then IsFileWriteable = RsResult(0)
    End Function
    
    Function MoveFile(RelOldFileName As String, RelNewFileName As String) As Boolean
      Dim RsResult As ADODB.Recordset
      Set RsResult = RPC.DoRPC("MoveFile", RelOldFileName, RelNewFileName)
      If NoErrorIn(RsResult) Then MoveFile = RsResult(0)
    End Function
    And finally the cHandler.cls Routines
    Code:
    Sub FileExists()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("FileExists", modFileOps.FileExists(MakeServerPath(RsIn(1))))
    End Sub
    
    Sub DeleteFile()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("DeleteFile", modFileOps.DeleteFile(MakeServerPath(RsIn(1))))
    End Sub
    
    Sub GetFileLen()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("GetFileLen", modFileOps.GetFileLen(MakeServerPath(RsIn(1))))
    End Sub
    
    Sub GetFileHash()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("GetFileHash", modFileOps.GetFileHash(MakeServerPath(RsIn(1))))
    End Sub
    
    Sub FolderExists()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("FolderExists", modFileOps.FolderExists(MakeServerPath(RsIn(1))))
    End Sub
    
    Sub DeleteDirectory()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("DeleteDirectory", modFileOps.DeleteDirectory(MakeServerPath(RsIn(1))))
    End Sub
    
    Sub CreateDirectory()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("CreateDirectory", modFileOps.CreateDirectory(MakeServerPath(RsIn(1))))
    End Sub
     
    Sub DirectoryHasSubDirs()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("DirectoryHasSubDirs", modFileOps.DirectoryHasSubDirs(MakeServerPath(RsIn(1))))
    End Sub
     
    Sub ReadTextContent()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("ReadTextContent", modFileOps.ReadTextContent(MakeServerPath(RsIn(1))))
    End Sub
    
    Sub WriteTextContent()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("WriteTextContent", modFileOps.WriteTextContent(MakeServerPath(RsIn(1)), CStr(RsIn(2))))
    End Sub
     
    Sub ReadChunk()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("ReadChunk", modFileOps.ReadChunk(MakeServerPath(RsIn(1)), RsIn(2), RsIn(3)))
    End Sub
     
    Sub AppendChunk()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Dim B() As Byte: B = RsIn(2)
      Set RsOut = CreateResultRs("AppendChunk", modFileOps.AppendChunk(MakeServerPath(RsIn(1)), B))
    End Sub
     
    Sub GetDirList()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = modFileOps.GetDirList(MakeServerPath(RsIn(1)))
    End Sub
     
    Sub IsFileWriteable()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("IsFileWriteable", modFileOps.IsFileWriteable(MakeServerPath(RsIn(1))))
    End Sub
     
    Sub MoveFile()
      On Error Resume Next 'allow Errors from subroutine-calls, to bubble up into this routine
      Set RsOut = CreateResultRs("MoveFile", modFileOps.MoveFile(MakeServerPath(RsIn(1)), MakeServerPath(RsIn(2))))
    End Sub
    As for your question regarding the ChunkSize - yes - I think 512KByte or 256KByte are entirely sufficient
    (you will not loose performance compared to larger chunksizes, and it is a small enough one, that you could even implement a little Progress-Indicator,
    which updates itself any "half a second" or so - after each Chunks Up- or Download).

    Also note, that I've tried to make the GetDirList-Routine into something that really returns an ADO-Recordset
    (in your first attempts, you should simply visualize the GetDirList-results in an MSHFlexGrid, before you try to "hang it into a TreeView-Control")

    Ok, and since I'm now kinda "into it, anyways" - here some Form-TestCode, with fully implemented UploadFile and DownloadFile-routines:
    Code:
    Private Sub Form_Click()
      Dim sErr As String
          sErr = UploadFile("c:\temp\test.jpg", "some.jpg")
          If Len(sErr) Then MsgBox sErr: Exit Sub
    
          sErr = DownloadFile("some.jpg", "c:\temp\test_down.jpg")
          If Len(sErr) Then MsgBox sErr: Exit Sub
    End Sub
    
    Public Function UploadFile(ClientFile$, ServerFile$, Optional ByVal ChunkSize& = 2 ^ 19)
      On Error GoTo 1
        Static Tmp As String, n As Currency: If n Then n = n + 1 Else n = Int(Now * 10000)
               Tmp = ServerFile & "." & n 'create a temporary filename (with a unique suffix)
               
        Dim B() As Byte, Offs As Currency, BytesRead As Long, sErr As String
        Do: B = "": Offs = Offs + BytesRead
            B = modFileOps.ReadChunk(ClientFile, Offs, ChunkSize)
            BytesRead = UBound(B) + 1
     
            If BytesRead > 0 Or Offs = 0 Then modFileOpsRPC.AppendChunk Tmp, B
        Loop While BytesRead
        
    1 If Err Then sErr = Err.Description Else sErr = CheckIdentity(ClientFile, Tmp)
      
      On Error Resume Next
        If Len(sErr) = 0 Then 'in case of no error so far, try to rename our temporary file to the intended FileName
           If Not modFileOpsRPC.MoveFile(Tmp, ServerFile) Then sErr = "Couldn't perform final File-Renaming"
        End If
        If Len(sErr) Then modFileOpsRPC.DeleteFile Tmp 'in case of an error, try to cleanup the temporary serverfile
        UploadFile = sErr
      On Error GoTo 0
    End Function
    
    Public Function DownloadFile(ServerFile$, ClientFile$, Optional ByVal ChunkSize& = 2 ^ 19)
      On Error GoTo 1
        Static Tmp As String, n As Currency: If n Then n = n + 1 Else n = Int(Now * 10000)
               Tmp = ClientFile & "." & n 'create a temporary filename (with a unique suffix)
    
        Dim B() As Byte, Offs As Currency, BytesRead As Long, sErr As String
        Do: B = "": Offs = Offs + BytesRead
            B = modFileOpsRPC.ReadChunk(ServerFile, Offs, ChunkSize)
            BytesRead = UBound(B) + 1
     
            If BytesRead > 0 Or Offs = 0 Then modFileOps.AppendChunk Tmp, B
        Loop While BytesRead
        
    1 If Err Then sErr = Err.Description Else sErr = CheckIdentity(Tmp, ServerFile)
    
      On Error Resume Next
        If Len(sErr) = 0 Then 'in case of no error so far, try to rename our temporary file to the intended FileName
           If Not modFileOps.MoveFile(Tmp, ClientFile) Then sErr = "Couldn't perform final File-Renaming"
        End If
        If Len(sErr) Then modFileOps.DeleteFile Tmp 'in case of an error, try to cleanup the temporary clientfile
        DownloadFile = sErr
      On Error GoTo 0
    End Function
    
    Public Function CheckIdentity(ClientFile$, ServerFile$) As String
    On Error GoTo 1
        If modFileOps.GetFileLen(ClientFile) <> modFileOpsRPC.GetFileLen(ServerFile) Then
          CheckIdentity = "Err: the FileSizes are different"
        ElseIf modFileOps.GetFileHash(ClientFile) <> modFileOpsRPC.GetFileHash(ServerFile) Then
          CheckIdentity = "Err: the FileHashes are different"
        End If
    1 If Err Then CheckIdentity = Err.Description
    End Function
    Olaf

  19. #19

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Olaf,

    Thank you so much, I really appreciate. This is powerful and robust stuff.
    And while we are at it. Thank you for going this journey with me. It was a quantum leap for me to get into client server stuff. It was hard, but worthwhile and generally it improved my programming skills immensely.

    PK

  20. #20

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Deleted
    Last edited by Peekay; Nov 4th, 2019 at 06:01 AM.

  21. #21

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    I have this code in the modFileOps module which was gratuitously given by Olaf in post 18 above:

    Code:
    Function ReadChunk(FileName As String, ByVal Offset As Currency, ByVal ChunkSize As Long) As Byte()
        Dim S As cStream
        Set S = New_c.FSO.OpenFileStream(FileName, STRM_READ Or STRM_SHARE_DENY_NONE)
            S.SetPosition Offset
            S.ReadToByteArr ReadChunk, ChunkSize
    End Function
    Although this worked quite well previously, I now get an error in code line 3. It says that: The specified module cannot be found. I am not sure what it refers to.
    The filename is correct.

    I presume New_C comes from the vbRichClient5 reference, but in my Project References, that reference is there and it does not indicate missing next to it. Could my Windows have changed that?

    Thanks
    PK
    Last edited by Peekay; Jul 29th, 2020 at 09:49 PM.

  22. #22

    Thread Starter
    Fanatic Member Peekay's Avatar
    Join Date
    Sep 2006
    Location
    Witbank, South Africa
    Posts
    784

    Re: Http Uploading files to server

    Solved, thank you. The dll was misplaced in another folder.
    PK

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width