无组件上传图片至SQLSERVER数据库(示例)

在无组件上传我刚试成功,所以提供代码给大家一起共享。

/*  addemployee.asp   */
<html>
<head>
<title>职工之家</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link rel="stylesheet" href="../css/site_css.css" type="text/css">
</head>

<script language="javascript">
<!--
 //选择分类
 ///
 function selectsort(txtSubject){
   var returnValue
   returnValue=window.showModalDialog("selMode.htm",null,"center:1;status:0;help:0;resized:0;dialogheight:300px;dialogwidth:206px");
   if (returnValue!="" && returnValue!=null){
      txtSubject.value=returnValue
   }
 }
 ///
 //合法性检查
 function isOK(thisForm){
   var strTemp,strValue,strLen,strExName
  if(thisForm.txtTitle.value==""){
      alert("提示:标题不能为空,请正确输入")
   thisForm.txtTitle.focus()
   return false
   }
   if(thisForm.txtSort.value==""){
      alert("提示:请正确选择分类")
   thisForm.txtSort.focus()
   return false
   }
   /*检查图片类型*/
   if(thisForm.file.value!=""){
      strTemp=thisForm.file.value
   strValue=strTemp.toLowerCase()
   strLen=strTemp.length
   strExName=strValue.substring(strLen-4,strLen)
   if (strExName!=".jpg" && strExName!=".gif"){
       alert("请选择jpg或者gif文件!")
    return false
   }
   return true
   }
 }
//-->
</script>

<body bgcolor="#FFFFFF" text="#000000" leftmargin="1" topmargin="1">
<form name="form1" method="post" action="transact1.asp" enctype="multipart/form-data">
  <table border="0" cellspacing="0" cellpadding="0">
    <tr>
      <td colspan="2" bgcolor="#006699" height="15">&nbsp;</td>
    </tr>
    <tr>
      <td class="textBlack">
        <div align="right">标题:</div>
      </td>
      <td>
        <input type="text" name="txtTitle" size="52" class="textarea">
      </td>
    </tr>
    <tr>
      <td class="textBlack">
        <div align="right">分类:</div>
      </td>
      <td>
        <input type="text" name="txtSort" size="35" class="textarea">
        <input type="button" name="Submit2" class="buttonSkid" οnclick="selectsort(txtSort);">
      </td>
    </tr>
    <tr>
      <td class="textBlack" valign="top">
        <div align="right">正文:</div>
      </td>
      <td>
        <textarea name="txtContent" rows="15" cols="50" class="textarea"></textarea>
      </td>
    </tr>
    <tr>
      <td height="14" class="textBlack" valign="top">
        <div align="right">图片:</div>
      </td>
      <td height="14" class="textBlack">
        <div align="left">
          <input type="file" name="file" size="35" class="textarea">
        </div>
      </td>
    </tr>
    <tr>
      <td height="42" class="textBlack" valign="top">&nbsp;</td>
      <td height="42" class="textBlack" valign="middle">
        <p>1、您上传的图片大小请控制在<font color="#FF0000"><b>500K</b></font>以内,否则不允许上传<br>
          2、你上传的图片必须为<font color="#FF0000"><b>150*130象素</b></font><br>
          3、上传上传图片的格式为JPG或者GIF</p>
      </td>
    </tr>
    <tr>
      <td height="39" class="textBlack">&nbsp;</td>
      <td height="39" valign="middle">
        <div align="center"><img src="../images/save.gif" width="85" height="19" onClick="if(isOK(form1)){form1.submit()}">  
          <img src="../images/close.gif" width="85" height="19" onClick="self.close();" ></div>
      </td>
    </tr>
  </table>
</form>
</body>
</html>
*************************************************************************

/* transact1.asp*/
<!--#include file="../func/conn.inc"-->
<!--#include file="../func/fupload.inc"-->
<!--#include file ="../func/myfunctions.inc"-->
<%
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
 Dim Fields
 Dim strTitle,strSort,strContent
 Dim rs,sSql
 Dim iMaxid
 Dim strMaxid
 Dim strlen    
 
 Set Fields = GetUpload()
 strTitle=BinaryToString(Fields("txtTitle").value)
 strSort=BinaryToString(Fields("txtSort").value)
 strContent=BinaryToString(Fields("txtContent").value)
 strSort=split(trim(strSort),"-")
 
 if instr(1,lcase(Fields("file").FileName),".jpg")=0 and instr(1,lcase(Fields("file").FileName),".gif")=0 then
    response.write "<script language='javascript'>alert('上传的图片必须是gif或者jpg格式的图片')</script>"
 response.write "<script language='javascript'>window.location='addemployee.asp';</script>"
    Response.end
 end if

 if Fields("file").Length>500000 then
    response.write "<script language='javascript'>alert('只允许不大于500k的图片上传');</script>"
    response.write "<script language='javascript'>window.location='addemployee.asp';</script>"
 response.end
 end if

 '/*存至数据库*/
     if Fields("file").FileName<>"" then
     Set rs=Server.CreateObject("ADODB.Recordset")
  sSql="select * from employee order by id desc"
  rs.open sSql,conn,2,2
  if not rs.eof  then
           iMaxid=Clng(rs("id"))+1                    
           strlen=4-len(cstr(iMaxid))
           strMaxid=string(strlen,"0") & cstr(iMaxid)  
        else
           strMaxid="0001"                             
        end if
  rs.addnew
        rs("id")=strMaxid
        rs("title")=strTitle
  rs("sort")=strSort(0)
  rs("img").AppendChunk Fields("file").Value
  rs("content")=quoteChg(strContent)
  rs("todate")=date()
        rs.update
        rs.close
        response.write "<script language='javascript'>alert('添加记录成功')</script>"
  end if
end if
%>

**********************************************************************
/*fupload.inc*/

<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
Dim UploadSizeLimit

'********************************** GetUpload **********************************
'.Name name of the form field (<Input Name="..." Type="File,...">)
'.ContentDisposition = Content-Disposition of the form field
'.FileName = Source file name for <input type=file>
'.ContentType = Content-Type for <input type=file>
'.Value = Binary value of the source field.
'.Length = Len of the binary data field
Function GetUpload()
Dim Result
Set Result = Nothing
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST"
Dim CT, PosB, Boundary, Length, PosE
CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-Type header
'response.write CT
'application/x-www-form-urlencoded
If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type header must be "multipart/form-data"
'This is upload request.
'Get the boundary and length from Content-Type header
PosB = InStr(LCase(CT), "boundary=") 'Finds boundary
If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary
Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get Content-Length header
if "" & UploadSizeLimit<>"" then
UploadSizeLimit = clng(UploadSizeLimit)
if Length > UploadSizeLimit then
' on error resume next 'Clears the input buffer
' response.AddHeader "Connection", "Close"
' on error goto 0
Request.BinaryRead(Length)
Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length,0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit,0) & "B"
exit function
end if
end if

If Length > 0 And Boundary <> "" Then 'Are there required informations about upload ?
Boundary = "--" & Boundary
Dim Head, Binary
Binary = Request.BinaryRead(Length) 'Reads binary data from client

'Retrieves the upload fields from binary data
Set Result = SeparateFields(Binary, Boundary)
Binary = Empty 'Clear variables
Else
Err.Raise 10, "GetUpload", "Zero length request ."
End If
Else
Err.Raise 11, "GetUpload", "No file sent."
End If
Else
Err.Raise 1, "GetUpload", "Bad request method."
End If
Set GetUpload = Result
End Function

'********************************** SeparateFields **********************************
'This function retrieves the upload fields from binary data and retuns the fields as array
'Binary is safearray of all raw binary data from input.
Function SeparateFields(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
Dim Fields
Boundary = StringToBinary(Boundary)

PosOpenBoundary = InstrB(Binary, Boundary)
PosCloseBoundary = InstrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)

Set Fields = CreateObject("Scripting.Dictionary")

Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
'Header and file/source field data
Dim HeaderContent, FieldContent
'Header fields
Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
'Helping variables
Dim Field, TwoCharsAfterEndBoundary
'Get end of header
PosEndOfHeader = InstrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))

'Separates field header
HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)

'Separates field content
FieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)

'Separates header fields from header
GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type

'Create one field and assign parameters
Set Field = CreateUploadField()
Field.Name = FormFieldName
Field.ContentDisposition = Content_Disposition
Field.FilePath = SourceFileName
Field.FileName = GetFileName(SourceFileName)
Field.ContentType = Content_Type
Field.Value = FieldContent
Field.Length = LenB(FieldContent)

Fields.Add FormFieldName, Field

'Is this ending boundary ?
TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))
'Binary.Mid(PosCloseBoundary + Len(Boundary), 2).String
isLastBoundary = TwoCharsAfterEndBoundary = "--"
If Not isLastBoundary Then 'This is not ending boundary - go to next form field.
PosOpenBoundary = PosCloseBoundary
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary )
End If
Loop
Set SeparateFields = Fields
End Function

'********************************** Utilities **********************************
Function BinaryToString(str)
strto = ""
for i=1 to lenb(str)
if AscB(MidB(str, i, 1)) > 127 then
strto = strto & chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
i = i + 1
else
strto = strto & Chr(AscB(MidB(str, i, 1)))
end if
next
BinaryToString=strto

End Function

Function StringToBinary(String)
Dim I, B
For I=1 to len(String)
B = B & ChrB(Asc(Mid(String,I,1)))
Next
StringToBinary = B
End Function

'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type)
Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))
Name = (SeparateField(Head, "name=", ";")) 'ltrim
If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)
FileName = (SeparateField(Head, "filename=", ";")) 'ltrim
If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)
Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function

'Separets one filed between sStart and sEnd
Function SeparateField(From, ByVal sStart, ByVal sEnd)
Dim PosB, PosE, sFrom
sFrom = LCase(From)
PosB = InStr(sFrom, sStart)
If PosB > 0 Then
PosB = PosB + Len(sStart)
PosE = InStr(PosB, sFrom, sEnd)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(From, PosB, PosE - PosB)
Else
SeparateField = Empty
End If
End Function

'Separetes file name from the full path of file
Function GetFileName(FullPath)
Dim Pos, PosF
PosF = 0
For Pos = Len(FullPath) To 1 Step -1
Select Case Mid(FullPath, Pos, 1)
Case "/", "/": PosF = Pos + 1: Pos = 0
End Select
Next
If PosF = 0 Then PosF = 1
GetFileName = Mid(FullPath, PosF)
End Function
</SCRIPT>
<SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT>
//The function creates Field object.
function CreateUploadField(){ return new uf_Init() }
function uf_Init(){
this.Name = null
this.ContentDisposition = null
this.FileName = null
this.FilePath = null
this.ContentType = null
this.Value = null
this.Length = null
}
</SCRIPT>

  • 0
    点赞
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
Delphi是一种集成开发环境(IDE),可以用于创建Windows应用程序。要在Delphi中备份SQL Server数据库,您可以使用以下步骤: 1. 首先,确保在Delphi中安装了相应的数据库连接组件,例如ADO(ActiveX 数据对象)组件。 2. 在Delphi中创建一个新的应用程序项目。 3. 使用ADO组件建立与SQL Server数据库的连接。在连接组件的属性中,设置数据库的服务器名称、用户名和密码等信息。 4. 创建一个备份操作的按钮或菜单项,使用户能够触发备份操作。 5. 在备份操作的事件处理程序中,编写代码以执行备份操作。以下是一个示例代码: ```delphi procedure TForm1.BtnBackupClick(Sender: TObject); var MyConnection: TADOConnection; BackupQuery: TADOQuery; begin // 创建SQL Server数据库连接 MyConnection := TADOConnection.Create(nil); MyConnection.LoginPrompt := False; MyConnection.ConnectionString := 'Provider=SQLOLEDB.1;Persist Security Info=False;' + 'User ID=username;Password=password;Initial Catalog=databaseName;Data Source=serverName'; try // 建立与数据库的连接 MyConnection.Connected := True; // 执行备份操作的SQL语句 BackupQuery := TADOQuery.Create(nil); BackupQuery.Connection := MyConnection; BackupQuery.SQL.Text := 'BACKUP DATABASE databaseName TO DISK = ''C:\backup\backup.bak'''; BackupQuery.ExecSQL; ShowMessage('数据库备份成功!'); except on E: Exception do ShowMessage('数据库备份失败:' + E.Message); end; // 释放资源 BackupQuery.Free; MyConnection.Free; end; ``` 以上代码示例中,需要替换username、password、databaseName和serverName为实际的SQL Server数据库连接信息。备份操作将数据库备份保存到指定的文件路径(C:\backup\backup.bak)。 通过以上步骤,您可以在Delphi中使用适当的代码来备份SQL Server数据库。请注意正确设置连接信息和备份路径,以确保成功备份数据库

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值