frminitnew.frm

朋友给的

        If rsList.Fields("ValueID").Value = 0 Then
            gCnn.Execute "Insert into [Parameters]([Paratype],[DESCRIPTION],[ValueID],[Value]) Values(" & rsList.Fields("PARATYPE").Value & ",'" & Trim(cboDMlist.Text) & "',1,'" & Trim(txtValue.Text) & "')"
        Else
            gCnn.Execute "Insert into [Parameters]([Paratype],[DESCRIPTION],[ValueID],[Value]) Values(" & rsList.Fields("PARATYPE").Value & ",'" & Trim(cboDMlist.Text) & "'," & rsList.Fields("ValueID").Value + 1 & ",'" & Trim(txtValue.Text) & "')"
        End If
    End If
    
    Call cboDMlist_Click
    txtValue.SetFocus
    txtValue.Text = ""
    Set rsList = Nothing
    Exit Sub
endlAdd:
    MsgBox Err.Description, vbCritical, "系统提示"
    Set rsList = Nothing
End Sub

Private Sub Form_Load()
Dim rsInit As ADODB.Recordset
Dim I As Integer
On Error GoTo EndLabel
'    If Me.WindowState = 0 Then Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
    If Me.WindowState = 0 Then Me.Move 0, 0
    Set rsInit = New ADODB.Recordset

    If rsInit.State = 1 Then rsInit.Close
    rsInit.Open "Select distinct DESCRIPTION,Paratype From [parameters] Order By Paratype", gCnn, adOpenStatic, adLockReadOnly
    cboDMlist.Clear
    lstDMLX.Clear
    If Not rsInit.BOF Then rsInit.MoveFirst
    For I = 0 To rsInit.RecordCount - 1
        cboDMlist.AddItem rsInit.Fields(0).Value
        lstDMLX.AddItem Format(rsInit.Fields(1).Value, "0###——") & rsInit.Fields(0).Value
        rsInit.MoveNext
    Next
    cboDMlist.Text = cboDMlist.List(0)
    Call cboDMlist_Click
    Set rsInit = Nothing
    Exit Sub
EndLabel:
    If Err = 0 Then
        MsgBox "数据库记录异常，请和管理员联系！", vbCritical, "系统提示"
    Else
        MsgBox Err.Description, vbCritical, "系统提示"
    End If
    Set rsInit = Nothing

End Sub

Private Sub cmdBakParam_Click()
Dim fso As FileSystemObject
Dim File1 As File
Dim ts As TextStream
Dim rsParam As ADODB.Recordset
Dim strOneLine As String
Dim strFileName As String
Dim I, j As Integer
On Error GoTo ErrLbl

    Set fso = New FileSystemObject
    Set rsParam = New ADODB.Recordset
    rsParam.Open "Select Paratype,DESCRIPTION,ValueID,Value,ValueName,Alias From Parameters Order by Paratype,ValueID", gCnn, adOpenStatic, adLockOptimistic

    If rsParam.RecordCount < 1 Then
        MsgBox "没有代码记录！", vbCritical, "系统提示"
        Set rsParam = Nothing
'        Set ts = Nothing
'        Set file1 = Nothing
        Set fso = Nothing
        Exit Sub
    End If
    
    CommonDialog1.DialogTitle = "文件输出"
    CommonDialog1.InitDir = App.Path
    CommonDialog1.Filename = "demo"
    CommonDialog1.Filter = "文本文件(*.txt)|*.txt"
    
    If InStr(CommonDialog1.Filename, "My docu") <> 0 Then
        MsgBox "请另选一个目录", vbInformation, "系统安全提示"
        Set rsParam = Nothing
'        Set ts = Nothing
'        Set file1 = Nothing
        Set fso = Nothing
        Exit Sub
    End If
    
    CommonDialog1.ShowSave
            
    strFileName = CommonDialog1.Filename
    
    If CommonDialog1.Flags = 0 Or Trim(strFileName) = "" Then
        Set rsParam = Nothing
        Set ts = Nothing
        Set File1 = Nothing
        Set fso = Nothing
        Exit Sub
    End If

    I = InStr(strFileName, ".")
    If I <> 0 Then
        strFileName = Left(strFileName, I - 1) & ".TXT"
    End If
    
    If fso.FileExists(strFileName) Then
        If MsgBox("文件已经存在，是否覆盖！", vbCritical + vbYesNo, "系统警告") = vbNo Then
            Set File1 = Nothing
            Set ts = Nothing
            Set fso = Nothing
            Set rsParam = Nothing
            Exit Sub
        End If
        fso.DeleteFile strFileName
'        Set file1 = fso.GetFile(strFileName)
'        Set ts = file1.OpenAsTextStream(ForWriting)
    End If
    Set ts = fso.CreateTextFile(strFileName, True)

    I = 0
    While I < rsParam.RecordCount
        strOneLine = ""
        For j = 0 To rsParam.Fields.count - 1
            strOneLine = strOneLine & rsParam.Fields(j).Value & ","
        Next j
        ts.WriteLine (strOneLine)
        rsParam.MoveNext
        I = I + 1
    Wend
    
    rsParam.Close
    ts.Close
    Set rsParam = Nothing
    Set ts = Nothing
    Set File1 = Nothing
    Set fso = Nothing
    MsgBox "生成代码文件成功！", vbInformation, "系统提示"
    Unload Me
    Exit Sub
ErrLbl:
    MsgBox Err.Description, vbCritical, "系统提示"
    Set File1 = Nothing
    Set ts = Nothing
    Set fso = Nothing
    Set rsParam = Nothing
End Sub

Private Sub cmdRollParam_Click()
Dim fso As FileSystemObject
Dim File1 As File
Dim ts As TextStream
Dim strFileName As String
Dim strOneLine As String
Dim jyfwarray() As String
Dim rs0 As ADODB.Recordset
On Error GoTo ErrorLbl
    gCnn.BeginTrans

    CommonDialog1.DialogTitle = "文件导入"
    CommonDialog1.InitDir = App.Path
    CommonDialog1.Filename = "demo"
    CommonDialog1.Filter = "文本文件(*.txt)|*.txt"
    If InStr(CommonDialog1.Filename, "My docu") <> 0 Then MsgBox "请另选一个目录", vbInformation, "系统安全提示": Exit Sub
    
    CommonDialog1.ShowOpen
    strFileName = CommonDialog1.Filename
    
    If CommonDialog1.Flags = 0 Or Trim(strFileName) = "" Then Exit Sub
    
    Set fso = New FileSystemObject
    Set File1 = fso.GetFile(strFileName)
    Set ts = File1.OpenAsTextStream(ForReading)
    Set rs0 = New ADODB.Recordset
    gCnn.Execute "delete  from  Parameters"
    rs0.Open "Parameters", gCnn, adOpenStatic, adLockOptimistic
    Dim I As Integer
    Do
        strOneLine = ts.ReadLine
'MsgBox strOneLine
        If Trim(strOneLine) = "#" Then Exit Do
        jyfwarray = Split(strOneLine, ",")
        rs0.AddNew
        rs0.Fields("Paratype") = Trim(jyfwarray(0))
        rs0.Fields("DESCRIPTION") = Trim(jyfwarray(1))
        rs0.Fields("ValueID") = Trim(jyfwarray(2))
        rs0.Fields("Value") = Trim(jyfwarray(3))
        rs0.Fields("ValueName") = Trim(jyfwarray(4))
        rs0.Fields("Alias") = Trim(jyfwarray(5))
        rs0.Update
        I = I + 1
    Loop While Not ts.AtEndOfStream

    gCnn.CommitTrans
    Set rs0 = Nothing
    Set File1 = Nothing
    Set ts = Nothing
    Set fso = Nothing
    MsgBox "代码数据导入成功！", vbInformation, "系统提示"
    Unload Me
    Exit Sub
ErrorLbl:
    gCnn.RollbackTrans
    Set rs0 = Nothing
    Set File1 = Nothing
    Set ts = Nothing
    Set fso = Nothing
    MsgBox Err.Description, vbCritical, "系统提示"
End Sub

Private Sub cmdcmdValueDel_Click()
Dim I As Integer
On Error GoTo endlDel
'    For i = lstDM.ListCount - 1 To 0 Step -1
    If lstDM.Selected(lstDM.ListIndex) And MsgBox("您确定要删除‘" & cboDMlist.Text & "’中的‘" & Trim(Mid(lstDM.List(lstDM.ListIndex), InStr(1, lstDM.List(lstDM.ListIndex), "&", vbTextCompare) + 1, Len(lstDM.List(lstDM.ListIndex)))) & "’项吗？", vbQuestion + vbOKCancel, "系统提示") = vbOK Then

    gCnn.Execute "Delete from [Parameters] where [DESCRIPTION] ='" & Trim(cboDMlist.Text) & "' and ValueID=" & Val(Mid(lstDM.List(lstDM.ListIndex), 1, InStr(1, lstDM.List(lstDM.ListIndex), "&", vbTextCompare) - 1))
        Call cboDMlist_Click
    End If
'    Next
    Exit Sub
endlDel:
    MsgBox Err.Description, vbCritical, "系统提示"
End Sub


Private Sub cboDMlist_Click()
Dim rsList As ADODB.Recordset
Dim I As Integer
On Error GoTo endll
    Set rsList = New ADODB.Recordset

        rsList.Open "Select ValueID,Value From [parameters] where DESCRIPTION='" & Trim(cboDMlist.Text) & "' order by ValueID ASC", gCnn, adOpenStatic, adLockReadOnly

    
    If rsList.RecordCount > 0 Then
        lstDM.Clear
        If Not rsList.BOF Then rsList.MoveFirst
        For I = 0 To rsList.RecordCount - 1
            lstDM.AddItem Format(rsList.Fields("ValueID").Value, "0###  &   ") & rsList.Fields("Value").Value
            rsList.MoveNext
        Next
    Else
'        MsgBox "没有这一项代码记录，请检查后再试！", vbInformation, "系统提示"
        Call Form_Load
    End If
    Set rsList = Nothing
    Exit Sub
endll:
    MsgBox Err.Description, vbCritical, "系统提示"
    Set rsList = Nothing
End Sub

Private Sub cboDMlist_KeyPress(keyascii As Integer)
    keyascii = 0
End Sub



Private Sub cmdClose_Click()
    Unload Me
End Sub



Private Sub txtDMLB_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then SendKeys "{Tab}"
End Sub

Private Sub txtDMLX_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then SendKeys "{Tab}"
End Sub

Private Sub txtValue_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then SendKeys "{Tab}"
End Sub