frmprojset.frm

来自「电梯检测系统是对电梯性能进行检测的系统。是一个用来学习的程序。」· FRM 代码 · 共 1,019 行 · 第 1/2 页

Sub SavePrj()
On Error GoTo SaveErr
Dim StrSql As String, Trec As Recordset, i As Integer

StrSql = "delete from  testitemhead where code='" & Trim$(PrjCodeCombo) & "' "
SetDb.Execute StrSql

StrSql = "delete from  testitemdetail where itemcode='" & Trim$(PrjCodeCombo) & "' "
SetDb.Execute StrSql

StrSql = "insert into testitemhead  values ('" & Trim$(PrjCodeCombo) & "','" & Trim$(DescText) & "','" & Trim$(TesterID) & "','" & Trim$(ProductType) & "','" & Trim$(TestEquipmentID) & "') "

SetDb.Execute StrSql

Exit Sub
SaveErr:
    MsgBox Err.Description, vbExclamation
    
End Sub

Sub SavePrjItem()
On Error GoTo SaveErr
Dim StrSql As String, Trec As Recordset, i As Integer

StrSql = " insert testitemdetail(testitemcode,itemcode)  values( "
StrSql = StrSql + "'" & PrjList.ListItems(i).SubItems(1) & "' , '" & Trim$(PrjCodeCombo) & "') "
SetDb.Execute StrSql

Exit Sub
SaveErr:
    MsgBox Err.Description, vbExclamation
    
End Sub


Private Sub AddCmd_Click()
lvwDB.Enabled = False
PrjList.Enabled = False
AddItemCmd.Enabled = False
MoveItemCmd.Enabled = False
DownCmd.Enabled = False
UpCmd.Enabled = False
SaveItemCmd.Enabled = False

End Sub

Private Sub AddItemCmd_Click()
On Error GoTo UpdateErr
Dim TempStr As String, TempItem As ListItem, Tmax As Integer
Dim tempnum
If lvwDB.SelectedItem Is Nothing Then Exit Sub

Set TempItem = PrjList.ListItems.Add()
TempItem.Key = lvwDB.SelectedItem.Key
With TempItem
    .Key = lvwDB.SelectedItem.Key + "_" & PrjList.ListItems.Count
    .Text = lvwDB.SelectedItem.Text
    .SmallIcon = "item"
End With
If lvwDB.SelectedItem.Text = "Message" Then
  TempStr = DefInputBox("Enter the Message", "Message")
    MsgNum = MsgNum + 1
    Open App.Path & "\temp\" & TempItem.Key & ".txt" For Output As #1
    Print #1, TempStr
    Close #1
End If
Set TempItem = Nothing
Exit Sub
UpdateErr:
    MsgBox Err.Description, vbExclamation

End Sub


Private Sub AddTrip()
On Error GoTo UpdateErr
Dim TempStr As String, TempItem As ListItem, Tmax As Integer
Dim tempnum
If lvwDB.SelectedItem Is Nothing Then Exit Sub

Set TempItem = PrjList.ListItems.Add()
TempItem.Key = lvwDB.SelectedItem.Key
With TempItem
    .Key = lvwDB.SelectedItem.Key + "_" & PrjList.ListItems.Count
    .Text = lvwDB.SelectedItem.Text
    .SmallIcon = "item"
End With
Set TempItem = Nothing
Exit Sub
UpdateErr:
    MsgBox Err.Description, vbExclamation

End Sub



Private Sub DelCmd_Click()
DelPrj
PrjList.ListItems.Clear
PrjCodeCombo = ""
DescText = ""

End Sub

Private Sub Command1_Click()
    Dim fso
    Dim i As Integer, TempI As Integer
    Dim TempStr
    Err.Clear
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.fileexists(App.Path & "\FuncTest\" & FileName.Text) Then
      MsgBox "File is not exist.", , "Error"
      Exit Sub
    End If
    If MsgBox("Delelte this file?This may lose some data,confirm do not need this file.", vbOKCancel, "Warning") = vbOK Then
      TempI = GetFromINI("count", "count", App.Path & "\functest\" & FileName.Text)
      For i = 1 To TempI
        If BolGetFromINI("test trip", i & "msg", App.Path & "\functest\" & FileName.Text) Then
          TempStr = GetFromINI("test trip", i & "msg", App.Path & "\functest\" & FileName.Text)
          Kill TempStr
          If Err.number = 53 Then
            MsgBox "Not found " & TempStr
          End If
        End If
      Next
      fso.deletefile App.Path & "\FuncTest\" & FileName.Text
      FileList.Refresh
      FileList_Click
    End If
  End Sub

Private Sub Command2_Click()
  Dim i As Integer
  Dim TempFuncTstAry() As String
  Dim TempFuncTstKeyAry() As String
  Dim TempFile As String
  Dim TempPath As String
  Dim MyChar As String
  Dim fso
  Dim TempI As Integer
  Dim TempStr
  If Not PrjList.ListItems.Count = 0 Then
    ReDim TempFuncTstAry(PrjList.ListItems.Count - 1) As String
    ReDim TempFuncTstKeyAry(PrjList.ListItems.Count - 1) As String
    'ReDim FuncTstAry(PrjList.ListItems.Count - 1) As String
    For i = 1 To PrjList.ListItems.Count
      TempFuncTstAry(i - 1) = PrjList.ListItems(i).Text
      TempFuncTstKeyAry(i - 1) = PrjList.ListItems(i).Key
    Next i
    FuncTstAry = TempFuncTstAry
    FuncTstKeyAry = TempFuncTstKeyAry
  End If
  MaxFuncTstNum = PrjList.ListItems.Count
  If Not MaxFuncTstNum = 0 Then
    Set fso = CreateObject("Scripting.FileSystemObject")
    TempPath = App.Path & "\FuncTest"
    If Trim$(FileName.Text) = "" Then
      MsgBox "File name can not be null."
      Exit Sub
    End If
    If LCase(right(Trim$(FileName.Text), 4)) = ".ini" Then
      TempFile = Trim$(FileName.Text)
    Else
      TempFile = Trim$(FileName.Text) & ".ini"
    End If
    
    Err.Clear
    On Error Resume Next
    If fso.fileexists(App.Path & "\FuncTest\" & TempFile) Then
        If MsgBox("Same name file exist!Delelte this file?This may lose some data,confirm do not need this file.", vbOKCancel, "Warning") = vbOK Then
          TempI = GetFromINI("count", "count", App.Path & "\functest\" & FileName.Text)
          For i = 1 To TempI
            If BolGetFromINI("test trip", i & "msg", App.Path & "\functest\" & FileName.Text) Then
              TempStr = GetFromINI("test trip", i & "msg", App.Path & "\functest\" & FileName.Text)
              Kill TempStr
''              If err.Number = 53 Then
''                MsgBox "File not found. " & TempStr
''              End If
            End If
          Next
          fso.deletefile App.Path & "\FuncTest\" & TempFile
        Else
          Exit Sub
        End If
    End If
    
    Open TempPath & "\" & TempFile For Output As #1
    Print #1, "[count]"
    Print #1, "count=" & (UBound(FuncTstAry) + 1)
    Print #1, "[Master]"
    If Option1.value = 1 Then
      Print #1, "master=1"
    Else
      Print #1, "master=0"
    End If
    Print #1, "[test trip]"
    For i = 0 To UBound(FuncTstAry)
      Print #1, i + 1 & "trip="; FuncTstAry(i)
      If FuncTstAry(i) = "Message" Then
        fso.copyfile App.Path & "\temp\" & FuncTstKeyAry(i) & ".txt", App.Path & "\message\" & left$(TempFile, Len(TempFile) - 4) & FuncTstKeyAry(i) & ".txt"
        Print #1, i + 1 & "Msg="; App.Path & "\message\" & left$(TempFile, Len(TempFile) - 4) & FuncTstKeyAry(i) & ".txt"
        Kill App.Path & "\temp\" & FuncTstKeyAry(i) & ".txt"
      End If
    Next i
    Close #1
  End If
  FileList.Refresh
  FileName.Text = ""
End Sub

Private Sub Command3_Click()
  Dim TempItem As ListItem
  Dim TempI As Integer, i As Integer, j As Integer
  Dim TempTrip As String, MsgPath As String
  Dim TripFound As Boolean
  Dim MasterOp As Byte
  Dim fso
  
  On Error GoTo Err
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  TripFound = False
  TempI = GetFromINI("count", "count", App.Path & "\functest\" & FileName.Text)
  On Error Resume Next
  MasterOp = GetFromINI("Master", "master", App.Path & "\functest\" & FileName.Text)
  If Err.number = 13 Then
    MsgBox Error$
  End If
  On Error GoTo Err
  If MasterOp = 1 Then
    Option1.value = 1
  Else
    Option1.value = 0
  End If
  PrjList.ListItems.Clear
  For i = 1 To TempI
    TempTrip = GetFromINI("test trip", i & "trip", App.Path & "\functest\" & FileName.Text)
    For j = 1 To lvwDB.ListItems.Count
      If lvwDB.ListItems(j).Text = TempTrip Then
        TripFound = True
        lvwDB.ListItems(j).Selected = True
        AddTrip
        If LCase(TempTrip) = "message" Then
           On Error Resume Next
           MsgPath = GetFromINI("test trip", i & "Msg", App.Path & "\functest\" & FileName.Text)
           fso.copyfile MsgPath, App.Path & "\temp\" & lvwDB.SelectedItem.Key + "_" & PrjList.ListItems.Count & ".txt"
           If Err.number = 76 Then
             MsgBox Error$
           End If
           On Error GoTo Err
        End If
      End If
    Next j
    If Not TripFound Then
      MsgBox "Error trip name,file damged."
    End If
    TripFound = False
  Next i
  Exit Sub
Err:
  MsgBox Error$
End Sub


Private Sub DownCmd_Click()
On Error GoTo UpdateErr
Dim TempItem As ListItem
Dim Str1 As String
Dim KeyStr1 As String, KeyStr2 As String
Dim i As Integer
If PrjList.SelectedItem Is Nothing Then Exit Sub
If PrjList.SelectedItem.Index >= PrjList.ListItems.Count Then Exit Sub
TempListView.ListItems.Clear
For i = 1 To PrjList.ListItems.Count
    Set TempItem = TempListView.ListItems.Add()
    With TempItem
        .Key = PrjList.ListItems(i).Key
        .Text = PrjList.ListItems(i).Text
       '.SmallIcon = "item"
    End With
    Set TempItem = Nothing
Next
SelectIndex = PrjList.SelectedItem.Index

PrjList.ListItems.Clear
For i = 1 To TempListView.ListItems.Count
    If i < SelectIndex Or i > SelectIndex + 1 Then
        Set TempItem = PrjList.ListItems.Add()
        With TempItem
            .Key = TempListView.ListItems(i).Key
            .Text = TempListView.ListItems(i).Text
           .SmallIcon = "item"
        End With
        Set TempItem = Nothing
    ElseIf i = SelectIndex + 1 Then
        Set TempItem = PrjList.ListItems.Add()
        With TempItem
            .Key = TempListView.ListItems(SelectIndex + 1).Key
            .Text = TempListView.ListItems(SelectIndex + 1).Text
           .SmallIcon = "item"
        End With
        Set TempItem = Nothing
        Set TempItem = PrjList.ListItems.Add()
        With TempItem
            .Key = TempListView.ListItems(SelectIndex).Key
            .Text = TempListView.ListItems(SelectIndex).Text
           .SmallIcon = "item"
        End With
        Set PrjList.SelectedItem = TempItem
        Set TempItem = Nothing
    End If
Next


'===end


Exit Sub
UpdateErr:
    MsgBox Err.Description, vbExclamation

End Sub

Private Sub ErrorCombo_Change()
End Sub

Private Sub ExitCmd_Click()
  On Error Resume Next
  Kill App.Path & "\temp\*.txt"
  Unload Me

End Sub


Private Sub FileList_Click()
  FileName.Text = Trim$(FileList.FileName)

End Sub

Private Sub FileName_Click()
  FileName.Text = Trim$(FileList.FileName)
End Sub

Private Sub Form_Load()
AddAllItem
MaxFuncTstNum = 0
MsgNum = 0
FileList.Path = App.Path & "\functest"
FillComp = False
FillSucc = False
SetWindowPos FrmLogin.hwnd, HWND_TOPMOST, 200, 100, 480, 190, SWP_SHOWWINDOW
Do Until FillComp
  DoEvents
Loop
If Not FillSucc Then
  Unload Me
  Exit Sub
End If

End Sub



Private Sub MoveItemCmd_Click()
On Error GoTo UpdateErr
Dim TempItem As ListItem

If PrjList.SelectedItem Is Nothing Then Exit Sub

'增加一条记录

If PrjList.SelectedItem.Text = "Message" Then
  Kill App.Path & "\temp\" & PrjList.SelectedItem.Key & ".txt"
End If
PrjList.ListItems.Remove (PrjList.SelectedItem.Index)

'MsgBox "The item is updated！", vbInformation

Exit Sub
UpdateErr:
    MsgBox Err.Description, vbExclamation


End Sub

Private Sub PrjCodeCombo_Click()
AddMeItem
End Sub


Private Sub PrjList_ItemClick(ByVal Item As MSComctlLib.ListItem)
  If Item Is Nothing Then Exit Sub
  If LCase(Item.Text) = "message" Then
    FrmInputBox.Text1.Text = ""
    On Error Resume Next
    Err.Clear
    FrmInputBox.Text1.FileName = App.Path & "\temp\" & Item.Key & ".txt"
    If Err.number = 75 Then
       If MsgBox("Not found message File,can not edit this message! Do you want to reedit this message", vbYesNo) = vbYes Then
         FrmInputBox.Text1.Text = ""
       Else
         Exit Sub
       End If
    End If
    FrmInputBox.Show
    FillComp = False
    FillSucc = False
    Do Until FillComp
      DoEvents
    Loop
    Open App.Path & "\temp\" & Item.Key & ".txt" For Output As #1
    Print #1, InputStr
    Close #1
  End If
End Sub


Private Sub SaveCmd_Click()
lvwDB.Enabled = True
PrjList.Enabled = True
AddItemCmd.Enabled = True
MoveItemCmd.Enabled = True
DownCmd.Enabled = True
UpCmd.Enabled = True
SaveItemCmd.Enabled = True

SavePrj

End Sub


Private Sub SaveItemCmd_Click()
On Error GoTo UpdateErr
Dim StrSql As String
StrSql = "update testitemdetail set ErrRun='" & ErrorCombo.List(ErrorCombo.ListIndex) & " ' ,OkRun='" & RightCombo.List(RightCombo.ListIndex) & "',Gotonum=" & Text2.Text & " "
StrSql = StrSql + " where itemcode='" & PrjList.SelectedItem.SubItems(1) & "' "
SetDb.Execute StrSql

MsgBox "The item is updated！", vbInformation

Exit Sub
UpdateErr:
    MsgBox Err.Description, vbExclamation
    
End Sub


Private Sub UpCmd_Click()
On Error GoTo UpdateErr
Dim TempItem As ListItem
Dim Str1 As String
Dim KeyStr1 As String, KeyStr2 As String
Dim i As Integer
Dim SelectIndex As Integer
If PrjList.SelectedItem Is Nothing Then Exit Sub
If PrjList.SelectedItem.Index <= 1 Then Exit Sub
'Add PrjList To TempListView
TempListView.ListItems.Clear
For i = 1 To PrjList.ListItems.Count
    Set TempItem = TempListView.ListItems.Add()
    With TempItem
        .Key = PrjList.ListItems(i).Key
        .Text = PrjList.ListItems(i).Text
       '.SmallIcon = "item"
    End With
    Set TempItem = Nothing
Next
SelectIndex = PrjList.SelectedItem.Index

PrjList.ListItems.Clear
For i = 1 To TempListView.ListItems.Count
    If i < SelectIndex - 1 Or i > SelectIndex Then
        Set TempItem = PrjList.ListItems.Add()
        With TempItem
            .Key = TempListView.ListItems(i).Key
            .Text = TempListView.ListItems(i).Text
           .SmallIcon = "item"
        End With
        Set TempItem = Nothing
    ElseIf i = SelectIndex - 1 Then
        Set TempItem = PrjList.ListItems.Add()
        With TempItem
            .Key = TempListView.ListItems(SelectIndex).Key
            .Text = TempListView.ListItems(SelectIndex).Text
           .SmallIcon = "item"
        End With
        Set PrjList.SelectedItem = TempItem
        Set TempItem = Nothing
    
        Set TempItem = PrjList.ListItems.Add()
        With TempItem
            .Key = TempListView.ListItems(i).Key
            .Text = TempListView.ListItems(i).Text
           .SmallIcon = "item"
        End With
        Set TempItem = Nothing
    
    End If
Next


Exit Sub
UpdateErr:
    MsgBox Err.Description, vbExclamation
End Sub