Solved

upload file

Posted on 2007-04-10
8
662 Views
Last Modified: 2012-06-21
hello,
I have a project that is using a module and I am wondering if its possible to remove
the module and make some changes so the app keeps working correctly without it!

this is the main.frm
Option Explicit
Dim blnConnected As Boolean

Private Function BuildFileUploadRequest(ByRef strData As String, ByRef DestUrl As URL, _
ByVal UploadName As String, ByVal FileName As String, ByVal MIMEType As String) As String
   
    Dim strHttp As String
    Dim strBoundary As String
    Dim strBody As String
    Dim lngLength As Long
       
    strBoundary = RandomAlphaNumString(32)

    strBody = "--" & strBoundary & vbCrLf
    strBody = strBody & "Content-Disposition: form-data; name=""" & _
                    UploadName & """; filename=""" & FileName & """" & vbCrLf
    strBody = strBody & "Content-Type: " & MIMEType & vbCrLf
    strBody = strBody & vbCrLf & strData
    strBody = strBody & vbCrLf & "--" & strBoundary & "--"
   
    lngLength = Len(strBody)
   
    strHttp = "POST " & DestUrl.URI & "?" & DestUrl.Query & " HTTP/1.0" & vbCrLf
    strHttp = strHttp & "Host: " & DestUrl.Host & vbCrLf
    strHttp = strHttp & "Content-Type: multipart/form-data, boundary=" & strBoundary & vbCrLf
    strHttp = strHttp & "Content-Length: " & lngLength & vbCrLf & vbCrLf
    strHttp = strHttp & strBody

    BuildFileUploadRequest = strHttp
End Function
                                     
Private Sub cmdUpload_Click()
    Dim strFile As String
    Dim strHttp As String
    Dim DestUrl As URL
    Dim MIMEType As String
    Dim Name As String
   
    If blnConnected Then Exit Sub
   
    DestUrl = ExtractUrl("http://mywebsite.com/upload/post.php")
   
    txtResponse.Text = ""
   
    strFile = GetFileContents(App.Path & "\mypicture.jpg")
   
    MIMEType = "application/octet-stream"
    Name = "file"
   
    strHttp = BuildFileUploadRequest(strFile, DestUrl, Name, "pictest.jpg", MIMEType)
   
    Winsock2.RemoteHost = DestUrl.Host
    Winsock2.Connect
   
    While Not blnConnected
        DoEvents
    Wend
   
    txtRequest.Text = strHttp
    Winsock2.SendData strHttp
End Sub

Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String
    Winsock2.GetData strData, vbString, bytesTotal
    txtResponse.Text = txtResponse.Text & strData
End Sub

Private Sub Winsock2_Connect()
    blnConnected = True
End Sub

Private Sub Winsock2_Close()
    Winsock2.Close
    blnConnected = False
End Sub

Private Function GetFileContents(ByVal strPath As String) As String
    Dim StrReturn As String
    Dim lngLength As Long
   
    lngLength = FileLen(strPath)
    StrReturn = String(lngLength, Chr(0))
   
    On Error GoTo ERR_HANDLER
   
    Open strPath For Binary As #1
   
    Get #1, , StrReturn
   
    GetFileContents = StrReturn
   
    Close #1
   
    Exit Function
   
ERR_HANDLER:
    MsgBox Err.Description, vbCritical, "ERROR"
   
    Err.Clear
End Function

Private Function RandomAlphaNumString(ByVal intLen As Integer)
    Dim StrReturn As String
   
    Dim X As Integer
    Dim c As Byte
   
    Randomize
   
    For X = 1 To intLen
        c = Int(Rnd() * 127)
   
        If (c >= Asc("0") And c <= Asc("9")) Or _
           (c >= Asc("A") And c <= Asc("Z")) Or _
           (c >= Asc("a") And c <= Asc("z")) Then
           
            StrReturn = StrReturn & Chr(c)
        Else
            X = X - 1
        End If
    Next X
   
    RandomAlphaNumString = StrReturn
End Function

----------------------------------------------------------------------------------------------------------------

'and this is the module
Option Explicit

Type URL
    Scheme As String
    Host As String
    Port As Long
    URI As String
    Query As String
End Type
   

' returns as type URL from a string
Function ExtractUrl(ByVal strUrl As String) As URL
    Dim intPos1 As Integer
    Dim intPos2 As Integer
   
    Dim retURL As URL
   
    '1 look for a scheme it ends with ://
    intPos1 = InStr(strUrl, "://")
   
    If intPos1 > 0 Then
        retURL.Scheme = Mid(strUrl, 1, intPos1 - 1)
        strUrl = Mid(strUrl, intPos1 + 3)
    End If
       
    '2 look for a port
    intPos1 = InStr(strUrl, ":")
    intPos2 = InStr(strUrl, "/")
   
    If intPos1 > 0 And intPos1 < intPos2 Then
        ' a port is specified
        retURL.Host = Mid(strUrl, 1, intPos1 - 1)
       
        If (IsNumeric(Mid(strUrl, intPos1 + 1, intPos2 - intPos1 - 1))) Then
                retURL.Port = CInt(Mid(strUrl, intPos1 + 1, intPos2 - intPos1 - 1))
        End If
    ElseIf intPos2 > 0 Then
        retURL.Host = Mid(strUrl, 1, intPos2 - 1)
    Else
        retURL.Host = strUrl
        retURL.URI = "/"
       
        ExtractUrl = retURL
        Exit Function
    End If
   
    strUrl = Mid(strUrl, intPos2)
   
    ' find a question mark ?
    intPos1 = InStr(strUrl, "?")
   
    If intPos1 > 0 Then
        retURL.URI = Mid(strUrl, 1, intPos1 - 1)
        retURL.Query = Mid(strUrl, intPos1 + 1)
    Else
        retURL.URI = strUrl
    End If
   
    ExtractUrl = retURL
End Function
0
Comment
Question by:Sabrin
  • 6
  • 2
8 Comments
 
LVL 4

Expert Comment

by:quiklearner
ID: 18887294
If the URL type isn't used in any other file in your project and the exacturl function isn't called from anywhere else you can easily move the entire contents of the module to the form..  I am not sure i really see any changes that will be necessary either
0
 
LVL 4

Expert Comment

by:quiklearner
ID: 18887308
obviously lose the option explicit though
0
 

Author Comment

by:Sabrin
ID: 18887322
the reason why i dont want the module is because im trying to keep the code as little a possible
and puting the module in the form will give me the same amount of code!
0
 
LVL 4

Expert Comment

by:quiklearner
ID: 18887345
then i will go through the code and do what i can.. give me a few..
0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

Author Comment

by:Sabrin
ID: 18887355
thanks a lot!
0
 
LVL 4

Expert Comment

by:quiklearner
ID: 18887358
I just noticed a problem where you are treating the contents of the file as a string..  I will correct this.  If this has worked before you got lucky..
0
 
LVL 4

Accepted Solution

by:
quiklearner earned 500 total points
ID: 18887687
OK, I have had to stop and start on this but I got it all smaller.  It made it bigger after i found the non-byte array approach you were using for the file.. ayway try this in the form:

Option Explicit
Private Type URL
    Scheme As String
    Host As String
    Port As Long
    URI As String
    Query As String
End Type
Dim blnConnected As Boolean

Private Function BuildFileUploadRequest(ByRef strData() As Byte, ByRef DestUrl As URL, _
ByVal UploadName As String, ByVal FileName As String, ByVal MIMEType As String) As Byte()
    Dim strBoundary As String, iFF As Integer, strBody As String
    Dim lngLength As Long, strHttp As String, sTemp() As String, bTemp() As Byte

    strBoundary = RandomAlphaNumString(32) ' get random boundry
    ' put character 182 in place of data to adjust for ubound and to be able to split
    strBody = "--" & strBoundary & vbCrLf & "Content-Disposition: form-data; name=""" & _
        UploadName & """; filename=""" & FileName & """" & vbCrLf & "Content-Type: " & _
        MIMEType & vbCrLf & vbCrLf & Chr(182) & vbCrLf & "--" & strBoundary & "--"
    sTemp = Split(strBody, Chr(182)) ' split it apart into srting()
    lngLength = Len(strBody) + UBound(strData) ' len is plus 1 but ubound is -1
    strHttp = "POST " & DestUrl.URI & "?" & DestUrl.Query & " HTTP/1.0" & vbCrLf & _
        "Host: " & DestUrl.Host & vbCrLf & "Content-Type: multipart/form-data, boundary=" & _
        strBoundary & vbCrLf & "Content-Length: " & lngLength & vbCrLf & vbCrLf
    ' trick:  use file to combine byte arrays and srings as converting one to the other
    iFF = FreeFile '  without iterating through all bytes is a pain
    Open "c:\" & strboundry & ".bin" For Binary As #iFF
    Put #iFF, , strHttp: Put #iFF, , sTemp(0): Put #iFF, , strData: Put #iFF, , sTemp(1)
    Close #1 ' put pieces in order   byte arrays and strings
    ReDim bTemp(FileLen("c:\" & strboundry & ".bin") - 1)
    Open "c:\" & strboundry & ".bin" For Binary As #iFF
    Get #iFF, , bTemp ' get contents
    Close #1
    Kill "c:\" & strboundry & ".bin" ' remove temp file
    txtResponse.Text = strHttp & strBody ' set textbox to version without binary
    BuildFileUploadRequest = bTemp
End Function
                                     
Private Sub cmdUpload_Click()
    If blnConnected Then Exit Sub
    Dim strHttp As String
    Dim DestUrl As URL, strTemp() As Byte
    Dim MIMEType As String
    Dim Name As String
   
    DestUrl = ExtractUrl("http://mywebsite.com/upload/post.php")
    strTemp = GetFileContents(App.Path & "\mypicture.jpg")
    MIMEType = "application/octet-stream"
    Name = "file"
    strTemp = BuildFileUploadRequest(strTemp, DestUrl, Name, "pictest.jpg", MIMEType)
   
    Winsock2.Connect DestUrl.Host
    While Not blnConnected
        DoEvents
    Wend
    Winsock2.SendData strTemp
End Sub

Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String
    Winsock2.GetData strData, vbString, bytesTotal
    txtResponse.Text = txtResponse.Text & strData
End Sub

Private Sub Winsock2_Connect()
    blnConnected = True
End Sub

Private Sub Winsock2_Close()
    Winsock2.Close
    blnConnected = False
End Sub

Private Function GetFileContents(ByVal strPath As String) As Byte()
    Dim bFile() As Byte, iFF As Integer
    ReDim bFile(FileLen(strPath) - 1)
    iFF = FreeFile
   
    On Error GoTo ERR_HANDLER
    Open strPath For Binary As #iFF
    On Error GoTo 0
   
    Get #iFF, , bFile
    Close #iFF
   
    Exit Function
ERR_HANDLER:
    MsgBox Err.Description, vbCritical, "ERROR"
    Err.Clear
End Function

Private Function RandomAlphaNumString(ByVal intLen As Integer)
    Dim c As Byte
    Randomize
   
    While Len(RandomAlphaNumString) < intLen
        c = Int(Rnd() * 127)
        If (c >= Asc("0") And c <= Asc("9")) Or _
           (c >= Asc("A") And c <= Asc("Z")) Or _
           (c >= Asc("a") And c <= Asc("z")) Then
           
            RandomAlphaNumString = RandomAlphaNumString & Chr(c)
        End If
    Wend
End Function

' returns as type URL from a string
Private Function ExtractUrl(ByVal strUrl As String) As URL
    Dim intPos1 As Integer, intPos2 As Integer, sTemp As String
   
    intPos1 = InStr(strUrl, "://") ' look for a scheme it ends with ://
    If intPos1 > 0 Then
        ExtractUrl.Scheme = Mid(strUrl, 1, intPos1 - 1) ' capture it
        strUrl = Mid(strUrl, intPos1 + 3) ' strip it
    End If
       
    intPos1 = InStr(strUrl, ":") '2 look for a port
    intPos2 = InStr(strUrl, "/")
    If intPos1 > 0 And intPos1 < intPos2 Then ' a port is specified
        ExtractUrl.Host = Mid(strUrl, 1, intPos1 - 1)
        sTemp = Mid(strUrl, intPos1 + 1, intPos2 - intPos1 - 1)
        If IsNumeric(sTemp) Then ExtractUrl.Port = CInt(sTemp)
    ElseIf intPos2 > 0 Then
        ExtractUrl.Host = Mid(strUrl, 1, intPos2 - 1)
    Else
        ExtractUrl.Host = strUrl
        ExtractUrl.URI = "/"
        Exit Function
    End If
    strUrl = Mid(strUrl, intPos2) ' strip the crap we just processed
   
    intPos1 = InStr(strUrl, "?") ' find a question mark ?
    If intPos1 > 0 Then
        ExtractUrl.URI = Mid(strUrl, 1, intPos1 - 1)
        ExtractUrl.Query = Mid(strUrl, intPos1 + 1)
    Else
        ExtractUrl.URI = strUrl
    End If
End Function

it could be smaller but would take me way more time...
0
 
LVL 4

Expert Comment

by:quiklearner
ID: 18887716
It took me probably a hlaf-hour or so to come up with the put() solution to how to combine the byte() with the string variable type..  I have done this differently before but that actually turned out to be awesome little trick i intend to use going forward!!
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Suggested Solutions

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now