asp+com - csu02 - 博客园

asp

<%@ Language=VBScript %>
<% Response.Buffer=true %>

<html>
<head>


<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>
<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>

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 阅读(372) 评论(0) 编辑收藏举报

刷新页面返回顶部

小牛

公告

小 牛

公告

小牛