Hello and welcome to our community! Is this your first visit?
Register
Enjoy an ad free experience by logging in. Not a member yet? Register.
Results 1 to 3 of 3
  1. #1
    New to the CF scene
    Join Date
    Dec 2006
    Posts
    5
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Exclamation Microsoft VBScript runtime (0x800A01A8) Object required: ''

    Error Type:
    Microsoft VBScript runtime (0x800A01A8)
    Object required: ''
    /hrdept/dl_add_url.asp, line 41


    Code:

    <%

    '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    curpagetype = "downloads"
    uploadPg = true
    sString = ""

    CurPageInfoChk = "1"
    function CurPageInfo ()
    PageName = "New Download"
    PageAction = "Submitted"
    CurPageInfo = PageAction & PageName
    end function

    %><!-- #INCLUDE file="config.asp" -->
    <!-- #INCLUDE file="includes/inc_clsUpload.asp" -->
    <!-- #INCLUDE file="inc_functions.asp" -->
    <!-- INCLUDE file="modules/downloads/dl_functions.asp" -->
    <!-- INCLUDE file="modules/downloads/dl_custom.asp" -->
    <!-- #INCLUDE file="inc_top.asp" -->
    <!-- INCLUDE file="includes/inc_ADOVBS.asp" -->
    <%


    if trim(objUpload.Fields("cat").Value) = "" then --> ERROR
    Response.Redirect("dl.asp")
    else
    cat = cLng(objUpload.Fields("cat").Value)


    name = ChkString(objUpload.Fields("name").Value,"sqlstring")
    URL = ChkString(objUpload.Fields("URL").Value,"url")
    key = ChkString(objUpload.Fields("key").Value,"sqlstring")
    size = ChkString(objUpload.Fields("size").Value,"sqlstring")
    description = ChkString(objUpload.Fields("des").Value,"sqlstring")
    email = ChkString(objUpload.Fields("mail").Value,"url")
    license = ChkString(objUpload.Fields("license").Value,"sqlstring")
    language = ChkString(objUpload.Fields("language").Value,"sqlstring")
    platform = ChkString(objUpload.Fields("platform").Value,"sqlstring")
    publisher = ChkString(objUpload.Fields("publisher").Value,"sqlstring")
    publisherURL = ChkString(objUpload.Fields("publisherURL").Value,"url")
    uploader = ChkString(objUpload.Fields("uploader").Value,"title")
    today = strCurDateString
    uLoad = filename

    Set objUpload = Nothing

    strSQL = "SELECT CAT_ID FROM DL_SUBCATEGORIES WHERE SUBCAT_ID = " & cat
    dim rsCategories
    set rsCategories = server.CreateObject("adodb.recordset")
    rsCategories.Open strSQL, my_Conn
    parent = rsCategories("CAT_ID")
    rsCategories.Close
    set rsCategories = nothing

    strSQL = "select UP_ACTIVE, UP_ALLOWEDUSERS, UP_ALLOWEDEXT from " & strTablePrefix & "UPLOAD_CONFIG where UP_LOCATION = 'download'"
    dim rsUload
    set rsUload = server.CreateObject("adodb.recordset")
    rsUload.Open strSQL, my_Conn
    uActive = rsUload("UP_ACTIVE")
    uAllowed = rsUload("UP_ALLOWEDUSERS")
    extAllowed = rsUload("UP_ALLOWEDEXT")
    rsUload.Close
    set rsUload = nothing

    if trim(uLoad) <> "" and FSOenabled = true and strAllowUploads = 1 and uActive = 1 and mLev >= uAllowed then
    banner = remotePath & parent & "/" & cat & "/" & uLoad
    url = banner
    end if
    if trim(uLoad) = "" then
    sString = ""
    end if

    if len(trim(name)) = 0 then
    sString = sString & "<li>Please enter Program Title.</li>"
    end if

    isOK = false
    if len(trim(url)) <= 8 and trim(uLoad) = "" then
    sString = sString & "<li>Please enter a Download URL.</li>"
    elseif len(trim(url)) > 8 and trim(uLoad) = "" then
    tmpExt = split(extAllowed,",")
    for ex = 0 to ubound(tmpExt)
    if right(url,3) = tmpExt(ex) then
    isOK = true
    end if
    next
    if not isOK then
    sString = sString & "<li>Please enter a valid Download URL.</li>"
    end if
    else

    strSql="Select URL from DL where URL like '%" & URL & "%'"
    set RS = my_Conn.execute(strSql)

    if not rs.eof then
    sString = sString & "<li>This Download already exists in our database.</li>"
    end if
    RS.close
    end if

    if cat = "--Please select one--" then
    sString = sString & "<li>Please select category that match your program.</li>"
    end if

    if len(trim(Description)) = 0 then
    sString = sString & "<li>Please enter program description.</li>"
    end if

    if len(trim(Description)) => 255 then
    sString = sString & "<li>" &len(trim(Description))&" characters. Your description is too long. 255 characters max</li>"
    end if

    if len(trim(Email)) = 0 then
    sString = sString & "<li>You must give an email address.</li>"
    else
    if EmailField(Email) = 0 then
    sString = sString & "<li>You Must enter a valid email address.</li>"
    end if
    end if


    end if

    if sString = "" then

    sSql = "SELECT APP_ID FROM "& strTablePrefix & "APPS WHERE APP_iNAME = 'downloads'"
    set rsA = my_Conn.execute(sSql)
    if not rsA.eof then
    intAppID = rsA("APP_ID")
    else
    intAppID = 0
    end if
    session.Contents("uploadType") = ""
    strSql = "INSERT INTO DL"
    strSql = strSql & "(NAME"
    strSql = strSql & ", URL"
    strSql = strSql & ", KEYWORD"
    strSql = strSql & ", CATEGORY"
    strSql = strSql & ", DESCRIPTION"
    strSql = strSql & ", EMAIL"
    strSql = strSql & ", POST_DATE"
    strSql = strSql & ", PARENT_ID"
    strSql = strSql & ", SHOW"
    strSql = strSql & ", BADLINK"
    strSql = strSql & ", FILESIZE "
    strSql = strSql & ", LICENSE "
    strSql = strSql & ", LANG "
    strSql = strSql & ", PLATFORM "
    strSql = strSql & ", PUBLISHER "
    strSql = strSql & ", PUBLISHER_URL "
    strSql = strSql & ", UPLOADER "
    strSql = strSql & ") "
    strSql = strSql & " VALUES ("
    strSql = strSql & "'" & name & "'"
    strSql = strSql & ", " & "'" & url & "'"
    strSql = strSql & ", " & "'" & key & "'"
    strSql = strSql & ", " & "'" & cat & "'"
    strSql = strSql & ", " & "'" & description & "'"
    strSql = strSql & ", " & "'" & email & "'"
    strSql = strSql & ", " & "'" & today & "'"
    strSql = strSql & ", " & "'" & parent & "'"
    if mlev=4 then
    strSql = strSql & ", " & "1"
    else
    strSql = strSql & ", " & "0"
    end if
    strSql = strSql & ", " & "0"
    strSql = strSql & ", " & "'" & size & "'"
    strSql = strSql & ", " & "'" & license & "'"
    strSql = strSql & ", " & "'" & language & "'"
    strSql = strSql & ", " & "'" & platform & "'"
    strSql = strSql & ", " & "'" & publisher & "'"
    strSql = strSql & ", " & "'" & publisherurl & "'"
    strSql = strSql & ", " & "'" & uploader & "'"
    strSql = strSql & ")"

    executeThis(strSQL)

    if trim(uLoad) <> "" and FSOenabled = true and strAllowUploads = 1 and uActive = 1 and mLev >= uAllowed then
    on error resume next
    set fso = Server.CreateObject("Scripting.FileSystemObject")
    dirPath = server.MapPath(remotePath) & "\"
    if fso.FolderExists(dirPath & parent) = false then
    fso.CreateFolder(dirPath & parent)
    end if
    if fso.FolderExists(dirPath & parent & "\" & cat) = false then
    fso.CreateFolder(dirPath & parent & "\" & cat)
    end if
    if fso.FileExists(dirPath & uLoad) = true then
    fso.MoveFile dirPath & uLoad, dirPath & parent & "\" & cat & "\" & uLoad
    end if
    set fso = nothing
    on error goto 0
    end if

    if mLev = 4 and intSubscriptions = 1 and strEmail = 1 then
    'send subscriptions emails
    eSubject = strSiteTitle & " - New Download"
    eMsg = "A new download has been submitted at " & strSiteTitle & vbCrLf
    eMsg = eMsg & "that you have a subscription for." & vbCrLf & vbCrLf
    eMsg = eMsg & "You can view the new downloads by visiting " & strHomeUrl & "dl.asp?cmd=3" & vbCrLf
    sendSubscriptionEmails intAppID,parent,cat,"0",eSubject,eMsg
    'response.Write("<br>Email sent<br>" )
    end if
    %>
    <table border="0" cellpadding="0" cellspacing="0" width="100%">
    <tr>
    <td class="leftPgCol">

    </td>
    <td class="mainPgCol">
    <%
    mwpThemeBlock_open()%>
    <table cellpadding="0" cellspacing="0" width="100%">
    <tr>
    <td valign="middle" width=100%>
    <center>
    <% if mlev=4 then%>Your file has been added to our database
    <%else%>Your File has been accepted for review.<br>
    Please wait 1-3 days for your File to be reviewed and added.
    <%end if%>
    <table border="0" cellpadding="4" cellspacing="0" width="60%" align="center">
    <tr>
    <td valign=top width=30%>
    <b>Name:</b>&nbsp;
    </td>
    <td valign=top align=left width=70%>
    <% Response.write name %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>URL:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write URL %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>Keywords:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write key %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>Email:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write Email %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>File Size:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write Size %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>License:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write License %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>Language:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write Language %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>Platform:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write Platform %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>Publisher:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write Publisher %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>Publisher's Website:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write Publisherurl %>
    </td>
    </tr>
    <tr>
    <td valign=top>
    <b>Uploaded by:</b>&nbsp;
    </td>
    <td valign=top align=left>
    <% Response.write Uploader %>
    </td>
    </tr>
    <tr>
    <td valign=top colspan=2>
    <b>Description:</b>&nbsp;
    </td>
    </tr>
    <tr>
    <td valign=top colspan=2>
    <% Response.write Description %>
    </td>
    </tr>
    </table>
    </td>
    </tr></table>
    <center><p><a href="dl.asp">Back to Download Categories </a></p>
    </center>
    <%
    mwpThemeBlock_close()%>
    </td>
    </tr>
    </table>
    <meta http-equiv="Refresh" content="10; URL=dl.asp">
    <%else
    'They have made an error, delete their upload, if there is one
    if FSOenabled = true and strAllowUploads = 1 then
    on error resume next
    set fso = Server.CreateObject("Scripting.FileSystemObject")
    dirPath = server.MapPath(downloadDir) & "\" & uLoad
    if fso.FileExists(dirPath) = true then
    fso.DeleteFile dirPath
    end if
    set fso = nothing
    end if %>
    <br>
    <table border="0" cellpadding="0" cellspacing="0" valign="top" width="100%">
    <tr>
    <td class="leftPgCol">

    </td>
    <td class="mainPgCol">
    <%

    mwpThemeBlock_open() %>
    <table border="0" cellpadding="0" cellspacing="0" width="100%">
    <tr>
    <td valign=top align=center>
    <p align="center"><span class="fSubTitle">There Was A Problem.</span></p>
    <table align="center" border="0">
    <tr>
    <td>
    <ul>
    <% =sString %>
    </ul>
    </td>
    </tr>
    </table>
    <p align="center"><a href="JavaScript:history.go(-1)">Go Back To Enter Data</a></p>
    </td>
    </tr>
    </table>
    <%mwpThemeBlock_close()%>
    </td>
    </tr>
    </table>
    <%end if%>
    <!-- #INCLUDE file="inc_footer.asp" -->

  • #2
    Senior Coder Spudhead's Avatar
    Join Date
    Jun 2002
    Location
    London, UK
    Posts
    1,856
    Thanks
    8
    Thanked 110 Times in 109 Posts
    Well, the problem is clearly with objUpload, isn't it?

    But seeing as you fail to indicate (a) what objUpload is and where you're initiating it, (b) what you've done so far to debug the problem (like, say, pasting the error message into Google or even doing a search on this forum), (c) any further information at all as to why and how you might be getting this error (like, say, "I just deleted all this other code and now it's not working"), or (d) pretty much anything at all except for pasting nearly 400 lines of irrelevant HTML, then I'm not in much of a position to help you, am I?

  • #3
    New to the CF scene
    Join Date
    Dec 2006
    Posts
    5
    Thanks
    0
    Thanked 0 Times in 0 Posts
    I try to use skyportal download features in maxwebportal.
    here the codes for <!-- #INCLUDE file="includes/inc_clsUpload.asp" -->.when i change the objUpload.Fields to Request.Form the error is fixed but...the process doesnt save in database.

    <%

    dim objUpload,remotePathMapped
    dim filename, sString, uString, grpsAllowed, bHasGrpAccess, max, upCntr
    redim arrUplds(1,1)
    arrUplds(0,0) = false
    arrUplds(0,1) = ""
    bHasGrpAccess = false
    sString = ""
    uString = ""
    filename = ""
    '####################################
    Class clsUpload
    Private mbinData
    Private mlngChunkIndex
    Private mlngBytesReceived
    Private mstrDelimiter
    Private CR
    Private LF
    Private CRLF
    Private mobjFieldAry()
    Private mlngCount

    Private Sub RequestData
    Dim llngLength
    mlngBytesReceived = Request.TotalBytes
    mbinData = Request.BinaryRead(mlngBytesReceived)
    End Sub

    Private Sub ParseDelimiter()
    mstrDelimiter = MidB(mbinData, 1, InStrB(1, mbinData, CRLF) - 1)
    End Sub

    Private Sub ParseData()
    Dim llngStart
    Dim llngLength
    Dim llngEnd
    Dim lbinChunk
    llngStart = 1
    llngStart = InStrB(llngStart, mbinData, mstrDelimiter & CRLF)
    While Not llngStart = 0
    llngEnd = InStrB(llngStart + 1, mbinData, mstrDelimiter) - 2
    llngLength = llngEnd - llngStart
    lbinChunk = MidB(mbinData, llngStart, llngLength)
    Call ParseChunk(lbinChunk)
    llngStart = InStrB(llngStart + 1, mbinData, mstrDelimiter & CRLF)
    Wend
    End Sub

    Private Sub ParseChunk(ByRef pbinChunk)
    Dim lstrName
    Dim lstrFileName
    Dim lstrContentType
    Dim lbinData
    Dim lstrDisposition
    Dim lstrValue
    lstrDisposition = ParseDisposition(pbinChunk)
    lstrName = ParseName(lstrDisposition)
    lstrFileName = ParseFileName(lstrDisposition)
    lstrContentType = ParseContentType(pbinChunk)
    If lstrContentType = "" Then
    lstrValue = CStrU(ParseBinaryData(pbinChunk))
    Else
    lbinData = ParseBinaryData(pbinChunk)
    End If
    Call AddField(lstrName, lstrFileName, lstrContentType, lstrValue, lbinData)
    End Sub

    Private Sub AddField(ByRef pstrName, ByRef pstrFileName, ByRef pstrContentType, ByRef pstrValue, ByRef pbinData)
    Dim lobjField
    ReDim Preserve mobjFieldAry(mlngCount)
    Set lobjField = New clsField
    lobjField.Name = pstrName
    lobjField.FilePath = pstrFileName
    lobjField.ContentType = pstrContentType
    If LenB(pbinData) = 0 Then
    lobjField.BinaryData = ChrB(0)
    lobjField.Value = pstrValue
    lobjField.Length = Len(pstrValue)
    Else
    lobjField.BinaryData = pbinData
    lobjField.Length = LenB(pbinData)
    lobjField.Value = ""
    End If
    Set mobjFieldAry(mlngCount) = lobjField
    mlngCount = mlngCount + 1
    End Sub

    Private Function ParseBinaryData(ByRef pbinChunk)
    Dim llngStart
    llngStart = InStrB(1, pbinChunk, CRLF & CRLF)
    If llngStart = 0 Then Exit Function
    llngStart = llngStart + 4
    ParseBinaryData = MidB(pbinChunk, llngStart)
    End Function

    Private Function ParseContentType(ByRef pbinChunk)
    Dim llngStart
    Dim llngEnd
    Dim llngLength
    llngStart = InStrB(1, pbinChunk, CRLF & CStrB("Content-Type:"), vbTextCompare)
    If llngStart = 0 Then Exit Function
    llngEnd = InStrB(llngStart + 15, pbinChunk, CR)
    If llngEnd = 0 Then Exit Function
    llngStart = llngStart + 15
    If llngStart >= llngEnd Then Exit Function
    llngLength = llngEnd - llngStart
    ParseContentType = Trim(CStrU(MidB(pbinChunk, llngStart, llngLength)))
    End Function

    Private Function ParseDisposition(ByRef pbinChunk)
    Dim llngStart
    Dim llngEnd
    Dim llngLength
    llngStart = InStrB(1, pbinChunk, CRLF & CStrB("Content-Disposition:"), vbTextCompare)
    If llngStart = 0 Then Exit Function
    llngEnd = InStrB(llngStart + 22, pbinChunk, CRLF)
    If llngEnd = 0 Then Exit Function
    llngStart = llngStart + 22
    If llngStart >= llngEnd Then Exit Function
    llngLength = llngEnd - llngStart
    ParseDisposition = CStrU(MidB(pbinChunk, llngStart, llngLength))
    End Function

    Private Function ParseName(ByRef pstrDisposition)
    Dim llngStart
    Dim llngEnd
    Dim llngLength
    llngStart = InStr(1, pstrDisposition, "name=""", vbTextCompare)
    If llngStart = 0 Then Exit Function
    llngEnd = InStr(llngStart + 6, pstrDisposition, """")
    If llngEnd = 0 Then Exit Function
    llngStart = llngStart + 6
    If llngStart >= llngEnd Then Exit Function
    llngLength = llngEnd - llngStart
    ParseName = Mid(pstrDisposition, llngStart, llngLength)
    End Function
    ' ------------------------------------------------------------------------------
    Private Function ParseFileName(ByRef pstrDisposition)
    Dim llngStart
    Dim llngEnd
    Dim llngLength
    llngStart = InStr(1, pstrDisposition, "filename=""", vbTextCompare)
    If llngStart = 0 Then Exit Function
    llngEnd = InStr(llngStart + 10, pstrDisposition, """")
    If llngEnd = 0 Then Exit Function
    llngStart = llngStart + 10
    If llngStart >= llngEnd Then Exit Function
    llngLength = llngEnd - llngStart
    ParseFileName = Mid(pstrDisposition, llngStart, llngLength)
    End Function

    Public Property Get Count()
    Count = mlngCount
    End Property

    Public Default Property Get Fields(ByVal pstrName)
    Dim llngIndex
    If IsNumeric(pstrName) Then
    llngIndex = CLng(pstrName)
    If llngIndex > mlngCount - 1 Or llngIndex < 0 Then
    Call Err.Raise(vbObjectError + 1, "inc_clsUpload.asp", "Object does not exist within the ordinal reference.")
    Exit Property
    End If
    Set Fields = mobjFieldAry(pstrName)
    Else
    pstrName = LCase(pstrname)
    For llngIndex = 0 To mlngCount - 1
    If LCase(mobjFieldAry(llngIndex).Name) = pstrName Then
    Set Fields = mobjFieldAry(llngIndex)
    Exit Property
    End If
    Next
    End If
    Set Fields = New clsField
    End Property

    Private Sub Class_Terminate()
    Dim llngIndex
    For llngIndex = 0 To mlngCount - 1
    Set mobjFieldAry(llngIndex) = Nothing

    Next
    ReDim mobjFieldAry(-1)
    End Sub

    Private Sub Class_Initialize()
    ReDim mobjFieldAry(-1)
    CR = ChrB(Asc(vbCr))
    LF = ChrB(Asc(vbLf))
    CRLF = CR & LF
    mlngCount = 0
    Call RequestData
    Call ParseDelimiter()
    Call ParseData
    End Sub

    Private Function CStrU(ByRef pstrANSI)
    Dim llngLength
    Dim llngIndex
    llngLength = LenB(pstrANSI)
    For llngIndex = 1 To llngLength
    CStrU = CStrU & Chr(AscB(MidB(pstrANSI, llngIndex, 1)))
    Next
    End Function

    Private Function CStrB(ByRef pstrUnicode)
    Dim llngLength
    Dim llngIndex
    llngLength = Len(pstrUnicode)
    For llngIndex = 1 To llngLength
    CStrB = CStrB & ChrB(Asc(Mid(pstrUnicode, llngIndex, 1)))
    Next
    End Function
    End Class
    '####################################
    Class clsField
    Public Name
    Private mstrPath
    Public FileDir
    Public FileExt
    Public FileName
    Public ContentType
    Public Value
    Public BinaryData
    Public Length
    Private mstrText

    Public Property Get BLOB()
    BLOB = BinaryData
    End Property

    Public Function BinaryAsText()
    Dim lbinBytes
    Dim lobjRs
    If Length = 0 Then Exit Function
    If LenB(BinaryData) = 0 Then Exit Function

    If Not Len(mstrText) = 0 Then
    BinaryAsText = mstrText
    Exit Function
    End If
    lbinBytes = ASCII2Bytes(BinaryData)
    mstrText = Bytes2Unicode(lbinBytes)
    BinaryAsText = mstrText
    End Function

    Public Sub SaveAs(ByRef pstrFileName)
    Const adTypeBinary=1
    Const adSaveCreateOverWrite=2
    Dim lobjStream
    Dim lobjRs
    Dim lbinBytes
    'check length
    If Length = 0 Then Exit Sub
    'check size
    If LenB(BinaryData) = 0 Then Exit Sub

    Set lobjStream = Server.CreateObject("ADODB.Stream")
    lobjStream.Type = adTypeBinary
    Call lobjStream.Open()
    lbinBytes = ASCII2Bytes(BinaryData)
    Call lobjStream.Write(lbinBytes)

    On Error Resume Next

    Call lobjStream.SaveToFile(pstrFileName, adSaveCreateOverWrite)

    if err<>0 then response.Write "<br>"&err.Description

    Call lobjStream.Close()
    Set lobjStream = Nothing
    End Sub

    Public Property Let FilePath(ByRef pstrPath)
    mstrPath = pstrPath
    If Not InStrRev(pstrPath, ".") = 0 Then
    FileExt = Mid(pstrPath, InStrRev(pstrPath, ".") + 1)
    FileExt = UCase(FileExt)
    End If
    If InStrRev(pstrPath, "\") = 0 Then
    FileName=pstrPath
    Else
    FileName = Mid(pstrPath, InStrRev(pstrPath, "\") + 1)
    End If
    If Not InStrRev(pstrPath, "\") = 0 Then
    FileDir = Mid(pstrPath, 1, InStrRev(pstrPath, "\") - 1)
    End If
    End Property

    Public Property Get FilePath()
    FilePath = mstrPath
    End Property

    private Function ASCII2Bytes(ByRef pbinBinaryData)
    Const adLongVarBinary=205
    Dim lobjRs
    Dim llngLength
    Dim lbinBuffer
    llngLength = LenB(pbinBinaryData)
    Set lobjRs = Server.CreateObject("ADODB.Recordset")
    Call lobjRs.Fields.Append("BinaryData", adLongVarBinary, llngLength)
    Call lobjRs.Open()
    Call lobjRs.AddNew()
    Call lobjRs.Fields("BinaryData").AppendChunk(pbinBinaryData & ChrB(0))
    Call lobjRs.Update()
    lbinBuffer = lobjRs.Fields("BinaryData").GetChunk(llngLength)
    Call lobjRs.Close()
    Set lobjRs = Nothing
    ASCII2Bytes = lbinBuffer
    End Function

    Private Function Bytes2Unicode(ByRef pbinBytes)
    Dim lobjRs
    Dim llngLength
    Dim lstrBuffer
    llngLength = LenB(pbinBytes)
    Set lobjRs = Server.CreateObject("ADODB.Recordset")
    Call lobjRs.Fields.Append("BinaryData", adLongVarChar, llngLength)
    Call lobjRs.Open()
    Call lobjRs.AddNew()
    Call lobjRs.Fields("BinaryData").AppendChunk(pbinBytes)
    Call lobjRs.Update()
    lstrBuffer = lobjRs.Fields("BinaryData").Value
    Call lobjRs.Close()
    Set lobjRs = Nothing
    Bytes2Unicode = lstrBuffer
    End Function
    End Class
    '######################################################################################


    Function logActivity(txtToLog)
    if FSOenabled then
    'on error resume next
    'log
    if logFlag = "1" then
    if logFile = "" then
    logFile = "upload.txt "
    end if
    Set fsoLog = Server.CreateObject("Scripting.FileSystemObject")
    Set logFile = fsoLog.OpenTextFile(remotePathMapped & "\" & logFile, 8, True)
    logFile.WriteLine(txtToLog)
    logFile.close
    set logFile = nothing
    set fsoLog = nothing
    end if
    end if
    end function

    function checkExt(byRef sName, byRef sExt)
    dim allowed, upl
    allowed = false
    if ar = true then
    for upl = 0 to ubound(extAllowed)
    if lcase(sExt) = lcase(extAllowed(upl)) then
    allowed = true
    end if
    next
    else
    if lcase(extAllowed) = lcase(sExt) then
    allowed = true
    end if
    end if

    if allowed = false then
    sString = sString & "<li>" & txtFileNotAllowed & " - <b>." & sExt & "</b></li>"
    'log
    txt = txtDate & ": " & Date() & "- " & txtAction & ": " & txtBadFileType & "(" & sExt & ") - " & txtUsrName & ": " & session.contents("loggedUser") & " - " & txtFileName & ": " & sName & " - " & txtUploaded & ": " & txtNo
    logActivity(txt)
    end if
    checkExt = allowed
    end function

    function checkSize(byRef sName, byRef sSize)
    dim allowed
    allowed = false
    if sSize > sizeLimit then
    allowed = false
    else
    allowed = true
    end if

    if allowed = false then
    sString = sString & "<li>" & txtFileTooLg & " '<b>" & (sizeLimit/1000) & " kb</b>'</li>"
    sString = sString & "<li>" & txtFileSzIs & " '<b>" & FormatNumber(sSize/1000,0) & " kb</b>'</li>"
    'log
    txt = txtDate & ": " & Date & "- " & txtAction & ": " & txtBadFileSize & "(" & FormatNumber(sSize/1000,0) & " kb) - " & txtUsrName & ": " & session.contents("loggedUser") & " - " & txtFileName & ": " & sName & " - " & txtUploaded & ": " & txtNo
    logActivity(txt)
    end if
    checkSize = allowed
    end function

    function checkThere(byRef sName, byRef sSize)
    dim allowed
    if sSize > 0 then
    if sName <> "" then
    allowed = true
    else
    allowed = false
    end if
    else
    allowed = false
    end if

    if allowed = false then
    sString = sString & "<li>" & txtNoFile & "</li>"
    end if
    checkThere = allowed
    end function

    function DateToStr3(dtDateTime)
    DateToStr3 = year(dtDateTime) & doublenum(Month(dtdateTime)) & doublenum(Day(dtdateTime)) & doublenum(Hour(dtdateTime)) & doublenum(Minute(dtdateTime)) & doublenum(Second(dtdateTime)) & ""
    end function

    function doublenum(fNum)
    if fNum > 9 then
    doublenum = fNum
    else
    doublenum = "0" & fNum
    end if
    end function

    function addslash(path)
    if right(path,1)="\" then addslash=path else addslash=path & "\"
    end function

    sub Upload()
    dim f,i,name,path,size,success,memID,ext

    set objUpload=New clsUpload

    success=false
    'targetPath=objUpload.Fields("folder").Value
    max=objUpload.Fields("max").Value
    if max = "" or max < 1 then
    max = 1
    end if
    upCntr = 0
    memID = objUpload.Fields("memID").Value
    today = datetostr3(now())

    'if hasAccess(grpsAllowed) then
    bHasGrpAccess = true
    for i = 1 to max
    name=objUpload.Fields("file" & i).FileName
    filename=objUpload.Fields("file" & i).FileName
    size=objUpload.Fields("file" & i).Length
    ext = objUpload.Fields("file" & i).FileExt

    if checkThere(name,size)=true and checkExt(name,ext)=true and checkSize(name,size)=true then
    upCntr = upCntr + 1
    uploadPg = true
    redim preserve arrUplds(upCntr,1)
    arrUplds(0,0) = true
    arrUplds(0,1) = ""
    arrUplds(upCntr,0) = filename

    'build the full path name
    filename = today & "_" & memID & "_" & i & "." & ext
    path=addslash(remotePathMapped) & filename
    'this line tells it to upload.
    objUpload.Fields("file" & i).SaveAs path

    arrUplds(upCntr,1) = filename

    'check to validate the upload
    Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
    if objFSO.FileExists(path) then
    'on error resume next
    set f=objFSO.GetFile(path)
    if IsObject(f) then
    if f.Size=size then success=true else success=false
    end if
    set f=nothing
    end if

    'if upload is an image, attempt to resize if needed and create a thumbnail.
    if (lcase(ext) = "gif" or lcase(ext) = "jpg" or lcase(ext) = "png" or lcase(ext) = "bmp") and success = true and intResize = 1 then '
    if imgSizeChk(path, w, h, c, strType) = true then
    if h > intMaxH or w > intMaxW then
    ' response.Write("remotePath:" & remotePath & "<br>")
    'response.Write("remotePath mapped:" & server.MapPath(remotePath) & "<br>")
    'response.Write("intMaxW:" & intMaxW & "<br>")
    'response.Write("intMaxH:" & intMaxH & "<br>")
    'response.Write("filename:" & filename & "<br>")
    'response.Write("Start resize<br>")
    ResizeUploadedFiles remotePath,"_rs",intMaxW,intMaxH,rsQuality,false,filename
    'response.Write("finish resize<br>")
    else
    'rename
    Old_ext = lcase("."&ext&"")
    new_ext = lcase("_rs."&ext&"")
    copyTo = replace(lcase(path),Old_ext,new_ext)
    objFSO.CopyFile path,copyTo
    end if
    if intDoThumb = 1 then
    'response.Write("<br>Start make thumb<br>")
    if h > intMaxTH or w > intMaxTW then
    'response.Write("Start thumb resize<br>")
    ResizeUploadedFiles remotePath,"_sm",intMaxTW,intMaxTH,rsQualityThumb,false,filename
    'response.Write("finish thumb resize<br>")
    else
    'response.Write("No resize needed<br>")
    'rename
    Old_ext = lcase("."&ext&"")
    new_ext = lcase("_sm."&ext&"")
    copyTo = replace(lcase(path),Old_ext,new_ext)
    objFSO.CopyFile path,copyTo
    end if
    end if
    end if
    end if
    set objFSO = nothing
    if not success then
    uString = uString & "<li><span class=""fAlert"">failed</span></li>"
    end if
    end if
    next
    'end if ':: hasAccess() check
    'response.write "<br>" & w & " x " & h & " " & c & " colors"
    'response.End()
    end sub
    '###########################################################################
    function moveToLoc(loc)
    on error resume next
    set fso = Server.CreateObject("Scripting.FileSystemObject")
    dirPath = server.MapPath(loc) & "\"
    if fso.FolderExists(server.MapPath(loc)) = false then
    fso.CreateFolder(server.MapPath(loc))
    end if
    if fso.FolderExists(server.MapPath(loc)) = false then
    sString = sString & "<li>" & loc & " " & txtNotCreated & "</li>"
    end if
    if fso.FolderExists(dirPath & parent) = false and sString = "" then
    fso.CreateFolder(dirPath & parent)
    end if
    if fso.FolderExists(dirPath & parent) = false and sString = "" then
    sString = sString & "<li>" & loc & parent & "<br>" & txtNotCreated & "</li>"
    end if
    if fso.FolderExists(dirPath & parent & "\" & cat) = false and sString = "" then
    fso.CreateFolder(dirPath & parent & "\" & cat)
    end if
    if fso.FolderExists(dirPath & parent & "\" & cat) = false and sString = "" then
    sString = sString & "<li>" & loc & "\" & parent & "\" & cat & "<br>" & txtNotCreated & "</li>"
    end if
    if fso.FileExists(dirPath & uLoad) = true then
    fso.MoveFile dirPath & uLoad, dirPath & parent & "\" & cat & "\" & uLoad
    else
    'sString = sString & "<li>Failed to Upload file</li>"
    end if
    if not fso.FileExists(dirPath & parent & "\" & cat & "\" & uLoad) = true then
    if sString = "" then
    sString = sString & "<li>" & txtFileNoMove & "</li>"
    end if
    end if
    set fso = nothing
    end function

    function chkIsFileThere(daPath)
    isThere = false
    if FSOenabled then
    set obFSO = Server.CreateObject("Scripting.FileSystemObject")
    if obFSO.FileExists(daPath) = true then
    isThere = true
    end if
    set obFSO = nothing
    end if
    chkIsFileThere = isThere
    end function

    function deleteFile(daPath)
    if FSOenabled then
    set obFSO = Server.CreateObject("Scripting.FileSystemObject")
    if obFSO.FileExists(daPath) = true then
    obFSO.DeleteFile(daPath)
    end if
    set obFSO = nothing
    end if
    end function


    %>


  •  

    Posting Permissions

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