小 牛

博客园 首页 新随笔 联系 订阅 管理

asp

<%@ Language=VBScript %>
<% Response.Buffer=true %>
<!--#include file="../Util.asp" -->
<html>
<head>
<!--#include file="../../inc/Title.inc" -->
<!--#include file="../../inc/ShowVersion.inc" -->
<meta name="VI60_defaultClientScript" content="VBScript">
<meta content="Microsoft FrontPage 4.0" name="GENERATOR">
<link rel="STYLESHEET" type="text/css" href="../../Css/oth.css">
<script ID="clientEventHandlersVBS" LANGUAGE="vbscript">
<!--
dim sinsp
vComarray = TranComarray
Bchk=False
sub window_onload
 toolbar "","div_btn","<%=Session("comarray")(5)%>"  '將toolbar引用進來,並決定要enabled的button
 document.all("btn_Exit").src="../../images/button/black/Exit.gif"
 txtcustid.FOCUS
end sub

sub txtcustid_onkeyup
 txtcustid.value =ucase(trim(txtcustid.value)) 
end sub


Sub btnExit_onclick
    frmAdd.Find.value =  sinsp
    frmAdd.submit
End Sub


Sub btnSave_onclick
 if len(trim(txtcustid.value))=0 then
    MsgBox "客戶代碼欄位不能空白"
    txtcustid.focus
    exit sub
 end if
 
 
 if len(trim(txtcustname.value))=0 then
    MsgBox "客戶名稱欄位不能空白"
    txtcustname.focus
    exit sub
 end if
 
  if isnumeric(left((txtcustid.value),1))=true then
    MsgBox "客戶代碼輸入錯誤,請重新輸入!"
    txtcustid.focus
    exit sub
  end if
 
 
  if isnumeric(mid((txtcustid.value),2,4))><true then
    MsgBox "客戶代碼輸入錯誤,請重新輸入!"
    txtcustid.focus
    exit sub
  end if
 

 
 chk_dupl
 
 if Bchk then
 scustid =Trim(txtcustid.VALUE)
 scustname =Trim(txtcustname.VALUE)
 scustnameb=Trim(txtcustnameb.VALUE)
 saddress=Trim(txtaddress.VALUE)
 scontact=Trim(txtcontact.VALUE)
 sphone=Trim(txtphone.VALUE)
 sfax=Trim(txtfax.VALUE)
 semail=Trim(txtemail.VALUE)
 
 
 'sauser=vComarray(0)
    vfield = Array("custid","custname","custnameb","address","contact","phone","fax","email")
 vvalue =Array(CSTR(scustid),Cstr(scustname),Cstr(scustnameb),Cstr(saddress),Cstr(scontact),Cstr(sphone),Cstr(sfax),Cstr(semail))
 Set OBJ = ADS.CreateObject("FICRFQ1001.RFQ1001at","HTTP://<%=request.ServerVariables("server_name")%>")
 Badd= OBJ.addmast(vComarray,vfield,vvalue)
 If Badd <> 0 Then
 MsgBox "資料新增成功"
 txtcustid.VALUE=""
 txtcustname.VALUE=""
 txtcustnameb.value=""
    txtaddress.value=""
    txtcontact.value=""
    txtphone.value=""
    txtfax.value=""
    txtemail.value=""
 
 txtcustid.focus()   
 
 Else
 msgBox "資料新增失敗"
 txtcustid.VALUE=""
 txtcustname.VALUE=""
 txtcustnameb.value=""
    txtaddress.value=""
    txtcontact.value=""
    txtphone.value=""
    txtfax.value=""
    txtemail.value=""
 
 txtcustid.focus()   
 End If
 END IF
 
End Sub

'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
Sub chk_dupl
    spn = txtcustid.value
 Set OBJ = ADS.CreateObject("FICRFQ1001.RFQ1001a","HTTP://<%=request.ServerVariables("server_name")%>")
 Set adoRs = OBJ.getdet(vComarray,cstr(spn))
              
 If adoRs.RecordCount > 0 Then
    MsgBox trim(scustid) & "客戶代碼已存在"
       txtcustid.value =""
       txtcustname.value =""
       txtcustnameb.value=""
       txtaddress.value=""
       txtcontact.value=""
       txtphone.value=""
       txtfax.value=""
       txtemail.value=""
      
       Bchk=false
   Else
   
    Bchk=true
 End If
End Sub

-->
</script>
</head>
<body><!--#include file="../../inc/toolbar.inc" --><!--#include file="../../inc/Timer.inc" -->
<OBJECT id=ADS height=1 width=1 classid=clsid:BD96C556-65A3-11D0-983A-00C04FC29E36></OBJECT>
<form NAME="frmAdd" METHOD="post" ACTION="RFQ1001.asp">
<input TYPE="hidden" NAME="Query" VALUE="Y">
<input TYPE="hidden" NAME="Find">
</form>
<p align="center">
<table background="../../images/banner/banner.gif" border="0" cellPadding="0" cellSpacing="0" height="38" style="LEFT: 200px; POSITION: absolute; TOP: 55px" width="375">
<tr>
 <td><p align="center"><b><font color="#000066" size="4">客戶基本資料新增</font></b></p></td>
</tr>
</table>

<div STYLE="LEFT: 30px; WIDTH: 700px; POSITION: absolute; TOP: 130px; TEXT-ALIGN: center" ALIGN="center">
<Center>
<table BORDER="2" bordercolordark="#168096" bordercolorlight="#168096" cellspacing="2" cellpadding="1" align=center>
    <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">客戶代碼 <font color="red"><%="*"%></font></td>
  <td><input id="txtcustid" name="txtcustid" maxlength="4"  value=""
  style="HEIGHT: 22px; WIDTH: 210px" > </td>
  
 </tr>
 
 <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">客戶名稱 <font color="red"><%="*"%></font> </td>
  <td><input id="txtcustname" name="txtcustname"  maxlength="100" value=""
   style="HEIGHT: 22px; WIDTH: 210px"></td>
  
 </tr>
 
 <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">客戶簡稱</td>
  <td><input id="txtcustnameb" name="txtcustnameb"  maxlength="20" value=""
   style="HEIGHT: 22px; WIDTH: 210px"></td>
  
 </tr>
 
 <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">客戶地址</td>
  <td><input id="txtaddress" name="txtaddress"  maxlength="100" value=""
   style="HEIGHT: 22px; WIDTH: 210px"></td>
  
 </tr>
 
 <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">聯系人</td>
  <td><input id="txtcontact" name="txtcontact"  maxlength="20" value=""
   style="HEIGHT: 22px; WIDTH: 210px"></td>
 
 </tr>
 
 <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">電話</td>
  <td><input id="txtphone" name="txtphone"  maxlength="18" value=""
   style="HEIGHT: 22px; WIDTH: 210px"></td>
  
 </tr>
 
 <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">傳真</td>
  <td><input id="txtfax" name="txtfax"  maxlength="18" value=""
   style="HEIGHT: 22px; WIDTH: 210px"></td>
  
 </tr>
 
 <tr>
  <td align="center" style="HEIGHT: 22px; WIDTH: 80px">E_MAIL</td>
  <td><input id="txtemail" name="txtemail"  maxlength="80" value=""
   style="HEIGHT: 22px; WIDTH: 210px"></td>
  
 </tr>
 
    <tr>
      <td COLSPAN="2" ALIGN="middle">
    <input TYPE="button" NAME="btnSave" VALUE="存檔">&nbsp;
       <INPUT  type=button value=離開 name=btnExit></td>
    <tr><td  colspan=2><%="(1)打"%><font color="red"><%="*"%> </font><%="欄位,為必填欄位不可空白"%> &nbsp;&nbsp;
 <br><%="(2)客戶代碼:依編碼原則("%><b><%="業務處"%></b><%="+客戶)輸入,如:"%><b><%="A"%></b><%="001"%>       
 
   </tr>
</table>
</Center>
</div>
</body>
</html>

com
Option Explicit
Public sSql As String
Private oGetPath As Object

Private Function ObjectControl_Activate() As Boolean
    ''MTS 啟動物件
End Function
Private Function ObjectControl_CanBePooled() As Boolean
    ''MTS 可 Pooling 物件
    ObjectControl_CanBePooled = True
End Function
Private Function ObjectControl_Deactivate() As Boolean
    ''MTS 結束物件
End Function
Public Function GetMast(aUser As Variant) As ADODB.Recordset
   ' On Error GoTo err_rtn
    Dim adoRs As New ADODB.Recordset
    Dim sTableName(0) As String, sFullName(0) As String, sDsn(0) As String
    Set oGetPath = CreateObject("M2000UTIL.GETPATH")

    sTableName(0) = "RFQCUST"
   
    oGetPath.getpath aUser, sTableName(), Null, sFullName(), sDsn()
   
    sSql = "select *  from " & sFullName(0)
    sSql = sSql + " order BY CUSTID"
          
    With adoRs
        .CursorLocation = adUseClientBatch
        .CursorType = adOpenKeyset
        .LockType = adLockBatchOptimistic
        .Open sSql, sDsn(0)
    End With
    Set GetMast = adoRs
   
    Set adoRs = Nothing
    Exit Function
err_rtn:
    Set GetMast = Nothing
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001.GetMast" & _
            vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function
Public Function GetDet(aUser As Variant, sWhere As String) As ADODB.Recordset
    On Error GoTo err_rtn
    Dim adoRs As New ADODB.Recordset
    Dim sTableName(1) As String, sFullName(1) As String, sDsn(1) As String
    Set oGetPath = CreateObject("M2000UTIL.GETPATH")

    sTableName(0) = "RFQCUST"
   
    oGetPath.getpath aUser, sTableName(), Null, sFullName(), sDsn()
   
    sSql = "select * "
    sSql = sSql + " FROM " + sFullName(0) + " C "
    sSql = sSql + " where c.custid like '" & sWhere & "'"
    With adoRs
        .CursorLocation = adUseClientBatch
        .CursorType = adOpenKeyset
        .LockType = adLockBatchOptimistic
        .Open sSql, sDsn(0)
    End With
    Set GetDet = adoRs
   
    Set adoRs = Nothing
    Exit Function
err_rtn:
    Set GetDet = Nothing
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001.GetDet" & _
            vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function

Public Function GetPrt(aUser As Variant, spn As String, ePn As String) As ADODB.Recordset
    'On Error GoTo err_rtn
    Dim adoRs As New ADODB.Recordset
    Dim sTableName(1) As String, sFullName(1) As String, sDsn(1) As String
    Set oGetPath = CreateObject("M2000UTIL.GETPATH")

    sTableName(0) = "RFQCUST"
   
    oGetPath.getpath aUser, sTableName(), Null, sFullName(), sDsn()
   
    sSql = "select  C.CUSTID,C.CUSTNAME,C.CUSTNAMEB,C.ADDRESS,C.CONTACT,C.PHONE,C.FAX,C.EMAIL,C.ADATE,C.UDATE from " & sFullName(0) & " c"
    sSql = sSql + " where c.CUSTID between '" & spn & "' and '" & ePn & "'"
    sSql = sSql + " order by A.CUSTID"
   
    With adoRs
        .CursorLocation = adUseClientBatch
        .CursorType = adOpenKeyset
        .LockType = adLockBatchOptimistic
        .Open sSql, sDsn(0)
    End With
   
    Set GetPrt = adoRs
   
    Set adoRs = Nothing
    Exit Function
err_rtn:
    Set GetPrt = Nothing
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001.GetPrt" & _
            vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function

 

com2

Option Explicit
Private sSql As String, sUser As String, sWhere As String
Private oGetPath As Object
Private laffcnt As Long
Public Function UpdMast(aUser As Variant, sFieldName As Variant, vFieldValue As Variant, sWhere As String) As Long
    Dim oContext As ObjectContext
    Set oContext = GetObjectContext()
  '  On Error GoTo err_rtn
   
    Dim adoCn As New ADODB.Connection
    Dim sTableName(1) As String, sFullName(1) As String, sDsn(1) As String
   
    Dim Vsfieldname(8) As Variant
    Dim Vvfieldvalue(8) As Variant
    Vsfieldname(0) = sFieldName(0)
    Vsfieldname(1) = sFieldName(1)
    Vsfieldname(2) = sFieldName(2)
    Vsfieldname(3) = sFieldName(3)
    Vsfieldname(4) = sFieldName(4)
    Vsfieldname(5) = sFieldName(5)
    Vsfieldname(6) = sFieldName(6)
    Vsfieldname(7) = sFieldName(7)
    Vsfieldname(8) = "UDATE"
  
   
    Vvfieldvalue(0) = vFieldValue(0)
    Vvfieldvalue(1) = vFieldValue(1)
    Vvfieldvalue(2) = vFieldValue(2)
    Vvfieldvalue(3) = vFieldValue(3)
    Vvfieldvalue(4) = vFieldValue(4)
    Vvfieldvalue(5) = vFieldValue(5)
    Vvfieldvalue(6) = vFieldValue(6)
    Vvfieldvalue(7) = vFieldValue(7)
    Vvfieldvalue(8) = CDate(Now())
 
   
   
     Set oGetPath = oContext.CreateInstance("M2000UTIL.GETPATH")
    sTableName(0) = "RFQCUST"
    sTableName(1) = "LRFQCUST"
   
    oGetPath.getpath aUser, sTableName(), Null, sFullName(), sDsn()
    sUser = aUser(0)
    adoCn.CursorLocation = adUseClient
    adoCn.Open sDsn(0)
    laffcnt = Update(adoCn, sFullName(0), Vsfieldname, Vvfieldvalue, sWhere)
   
    '寫入LRFQCUST
   
    If laffcnt >= 1 Then
        sSql = "insert into " & sFullName(1) _
            & " select *,'U','" + Format(Now, "mm/dd/yyyy HH:mm:ss") + "','" & sUser & "'" _
            & " from " & sFullName(0) & " where " & sWhere
        adoCn.Execute sSql
    End If
    UpdMast = laffcnt: oContext.SetComplete: adoCn.Close: Set adoCn = Nothing
    Exit Function
err_rtn:
    UpdMast = 0
    oContext.SetAbort
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001aT.UpdMast" & vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function
Public Function Update(adoCn As Connection, sTable As String, vFieldName As Variant, vFieldValue As Variant, sClause As String) As Long
    ''依 sClause 的條件以 array 的方式更新 sTable 的一筆或多筆資料
    '-----------------------------------------------------------------------------------
    ''sTableName     Table名,由GetPath抓全名
    ''sFieldsName()  欄位名稱的 array
    ''sFieldsValue() 欄位值的 array
    ''sClause        更新的條件
    '------------------------------------------------------------------------------------
    Dim oContext As ObjectContext
    Set oContext = GetObjectContext()
 '   On Error GoTo err_rtn
   
    Dim iCnt As Integer, laffcnt As Long
   
    sSql = "UPDATE " & sTable & " SET "
    For iCnt = LBound(vFieldName) To UBound(vFieldName)
        sSql = sSql & vFieldName(iCnt) & "=" & TranType(vFieldValue(iCnt)) & ","
    Next iCnt
    sSql = Left(sSql, Len(sSql) - 1) & " Where " & sClause
    adoCn.Execute sSql, laffcnt
   
    Update = laffcnt: oContext.SetComplete
    Exit Function
   
err_rtn:
    Update = 0
    oContext.SetAbort
Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001aT.Update" & vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function
Private Function TranType(ChkData As Variant) As String
    ''配合 SQL 語法, 將非數字資料前後加上單引號
    '-----------------------------------------------------------------------------------
    ''ChkData         要檢查是否轉換的資料
    '------------------------------------------------------------------------------------

   ' On Error GoTo err_rtn
        If IsNull(ChkData) Then
                TranType = "Null"
        Else
          If Trim(ChkData) = "getdate()" Then
             TranType = CStr(ChkData)   ' getdate()為函數
          Else
            Select Case VarType(ChkData)
                Case vbInteger, vbLong, vbVDouble, vbDecimal, VbVarType.vbCurrency, vbVSingle
                    TranType = CStr(ChkData)
                Case Else
                    If InStrRev(ChkData, "'") <> 0 Then ChkData = Replace(ChkData, "'", "`")   ' 防止單引號
                    TranType = "'" & ChkData & "'"
                    If VarType(ChkData) = 7 Then
                    TranType = "'" + Format(ChkData, "mm/dd/yyyy HH:mm:ss") + "'"
                    End If
            End Select
          End If
        End If
    Exit Function
   
err_rtn:
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001aT.TranType" & vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function

Public Function AddMast(aUser As Variant, sFieldName As Variant, vFieldValue As Variant) As Long
    Dim oContext As ObjectContext
    Set oContext = GetObjectContext()
   ' On Error GoTo err_rtn
   
    Dim adoCn As New ADODB.Connection, oGetPath As Object
    Dim sTableName(1) As String, sFullName(1) As String, sDsn(1) As String
    Dim laffcnt As Long
    Dim Vsfieldname(9) As Variant
    Dim Vvfieldvalue(9) As Variant
   
    Vsfieldname(0) = sFieldName(0)
    Vsfieldname(1) = sFieldName(1)
    Vsfieldname(2) = sFieldName(2)
    Vsfieldname(3) = sFieldName(3)
    Vsfieldname(4) = sFieldName(4)
    Vsfieldname(5) = sFieldName(5)
    Vsfieldname(6) = sFieldName(6)
    Vsfieldname(7) = sFieldName(7)
    Vsfieldname(8) = "ADATE"
    Vsfieldname(9) = "UDATE"
   
    Vvfieldvalue(0) = vFieldValue(0)
    Vvfieldvalue(1) = vFieldValue(1)
    Vvfieldvalue(2) = vFieldValue(2)
    Vvfieldvalue(3) = vFieldValue(3)
    Vvfieldvalue(4) = vFieldValue(4)
    Vvfieldvalue(5) = vFieldValue(5)
    Vvfieldvalue(6) = vFieldValue(6)
    Vvfieldvalue(7) = vFieldValue(7)
    Vvfieldvalue(8) = CDate(Now())
    Vvfieldvalue(9) = CDate(Now())
   
   
   Set oGetPath = oContext.CreateInstance("M2000UTIL.GETPATH")
'     Set oGetPath = CreateObject("M2000UTIL.GETPATH")

    sTableName(0) = "RFQCUST"
    sTableName(1) = "LRFQCUST"
    oGetPath.getpath aUser, sTableName(), Null, sFullName(), sDsn()
    adoCn.Open sDsn(0)
    laffcnt = Insert(adoCn, sFullName(0), Vsfieldname, Vvfieldvalue)
  If laffcnt >= 1 Then
        sSql = "insert into " & sFullName(1) _
            & " select *,'I','" + Format(Now, "mm/dd/yyyy HH:mm:ss") + "','" & aUser(0) & "'" _
            & " from " & sFullName(0) & " where CUSTID=  '" & Vvfieldvalue(0) & "' "
        adoCn.Execute sSql
    End If
 
    AddMast = laffcnt: oContext.SetComplete: adoCn.Close: Set adoCn = Nothing
    Exit Function
   
err_rtn:
    AddMast = 0
    oContext.SetAbort
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001aT.AddMast" & vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function

Public Function Insert(adoCn As Connection, sTable As String, sFieldName As Variant, vFieldValue As Variant) As Long
    '依陣列串字串去Insert sTable
    '-----------------------------------------------------------------------------------
    ''sTableName     Table名,由GetPath抓全名
    ''sFieldsName()  欄位名稱的 array
    ''sFieldsValue() 欄位值的 array
    '------------------------------------------------------------------------------------
    Dim oContext As ObjectContext   ' 前3行為有Transation統一寫法,請參照
    Set oContext = GetObjectContext()
   ' On Error GoTo err_rtn
   
    Dim iCnt As Integer, laffcnt As Long
   
    sSql = "INSERT INTO " & sTable & " (" & sFieldName(0)
        For iCnt = 1 To UBound(sFieldName)
            sSql = sSql & "," & sFieldName(iCnt)
        Next iCnt
    sSql = sSql & ") Values (" & TranType(vFieldValue(0))
        For iCnt = 1 To UBound(sFieldName)
            sSql = sSql & "," & TranType(vFieldValue(iCnt))
        Next iCnt
    sSql = sSql & ")"
    adoCn.Execute sSql, laffcnt
   
    Insert = laffcnt: oContext.SetComplete
    Exit Function
   
err_rtn:
    Insert = 0
    oContext.SetAbort
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001aT.AddMast" & vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function
Public Function DelMast(aUser As Variant, spn As String) As Long
    Dim oContext As ObjectContext
    Set oContext = GetObjectContext()
    On Error GoTo err_rtn
   
    Dim adoCn As New ADODB.Connection, oGetPath As Object
    Dim sTableName(1) As String, sFullName(1) As String, sDsn(1) As String
    Dim laffcnt As Long
    sUser = aUser(0)
    Set oGetPath = oContext.CreateInstance("M2000UTIL.GETPATH")
    sTableName(0) = "RFQCUST"
    sTableName(1) = "LRFQCUST"
    oGetPath.getpath aUser, sTableName(), Null, sFullName(), sDsn()
    adoCn.Open sDsn(0)
  
      '寫入LOGBONDGOODS
  
       sSql = "insert into " & sFullName(1) _
           & " select *,'D','" + Format(Now, "mm/dd/yyyy HH:mm:ss") + "','" & sUser & "'" _
           & " from " & sFullName(0) & "  where CUSTID like'" & spn & "'"
       adoCn.Execute sSql
      
      ' 刪除記錄
  
    sSql = "delete " & sFullName(0) & " where CUSTID like'" & spn & "'"
    adoCn.Execute sSql, laffcnt
 
   
    DelMast = laffcnt: oContext.SetComplete: adoCn.Close: Set adoCn = Nothing
    Exit Function
   
err_rtn: '
    DelMast = 0
    oContext.SetAbort
    Err.Raise Err.Number, Err.Source, "Porgram: FICRFQ1001.RFQ1001aT.DelMast" & vbCrLf & "Source:" & Err.Source & vbCrLf & "Error:" & Err.Description
End Function


 

posted on 2007-01-04 11:31  csu02  阅读(343)  评论(0编辑  收藏  举报