frmfind.frm

一个把自己的东西刻成光盘后自动查询和启动的原代码

End Sub

Private Sub HImgDrag_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

HImgDrag.Move HPicDrag.Left, HPicDrag.Top, HPicDrag.Width, HPicDrag.Height
HPicDrag.Visible = False
HDragFlag = False
gHeightRate = HPicDrag.Top / Me.ScaleHeight
Call Form_Resize

End Sub


Private Sub LVResult_DblClick()
If LVResult.Tag = "0" Then '文件
   Call ViewFileReg(LVResult, FrmFind, 2)
Else
   Call ViewVolumeReg(LVResult, FrmFind, 2)
End If
End Sub

Private Sub LVViewField_ItemCheck(ByVal Item As MSComctlLib.ListItem)
On Error GoTo Err
Dim i As Integer
If Item.Checked = True Then
   LVResult.ColumnHeaders.Add , Item.key, Item.Text
Else
   For i = 1 To LVResult.ColumnHeaders.Count
      If LVResult.ColumnHeaders(i).key = Item.key Then LVResult.ColumnHeaders.Remove i
   Next i
End If
Err:
End Sub


Private Sub m_Exit_Click()
Unload Me
End Sub

Private Sub m_Operate_Do_Click(Index As Integer)
Dim tSql As String
Dim tWhereStr As String
Dim i, j As Integer
Dim tTypeCode As String
Dim tFieldName As String '字段名称
Dim t_Dict_Type As String '数据字典
Dim tItem As ListItem
Dim tFieldValue As String
Dim tFileFullName As String
Dim tStr As String
Dim tBool As Boolean
Dim tStrArray(1 To 6) As String

On Error GoTo Err

Select Case Index
   Case 0 '打开
      CmnDlg.CancelError = False
      'CmnDlg.Flags = cdlOFNOverwritePrompt
      CmnDlg.Filter = "定制文件 (*.qry)|*.qry"
      CmnDlg.DialogTitle = "请选择定制的查询文件"
      CmnDlg.ShowOpen
      tFileFullName = CmnDlg.FileName
      If tFileFullName = "" Then Exit Sub
    
      For i = 0 To LVViewField.ListItems.Count - 1
          LVViewField.ListItems(i + 1).Checked = False
      Next i
      LVCondition.ListItems.Clear
      LVSQL.ListItems.Clear
    
      Close #2
      Open tFileFullName For Input As #2
      
      '档案类型
      Line Input #2, tStr
      tBool = False
      CbxTypeCode.ListIndex = -1
      For i = 0 To CbxTypeCode.ListCount - 1
          If tStr = CbxTypeCode.List(i) Then
             CbxTypeCode.ListIndex = i
             tBool = True
             Exit For
          End If
      Next i
      If tBool = False Then GoTo Err
      
      '对象类型
      Line Input #2, tStr
      CbxObject.ListIndex = CInt(tStr)
            
      Line Input #2, tStr
      Line Input #2, tStr
      Do While tStr <> "显示条件" And Not EOF(2) '显示字段
         For i = 1 To LVViewField.ListItems.Count
            If LVViewField.ListItems(i).key = tStr Then
               LVViewField.ListItems(i).Checked = True
               Call LVViewField_ItemCheck(LVViewField.ListItems(i))
               Exit For
            End If
         Next i
         Line Input #2, tStr ' 读入一行数据并将其赋予某变量。
      Loop
      
      Line Input #2, tStr
      Do While tStr <> "条件" 'And Not EOF(2)  '显示字段
         For i = 1 To 6
            Call GetValue(tStrArray(i), CStr(i), tStr)
            If i = 1 Then
               Set tItem = LVCondition.ListItems.Add(, "K" + Format(LVCondition.ListItems.Count + 1, "0000"), tStrArray(i))
            Else
               tItem.SubItems(i - 1) = tStrArray(i)
            End If
         Next i
         Line Input #2, tStr ' 读入一行数据并将其赋予某变量。
      Loop
      
      
      Do  '显示字段
         Line Input #2, tStr
         For i = 1 To 6
            Call GetValue(tStrArray(i), CStr(i), tStr)
            If i = 1 Then
               Set tItem = LVSQL.ListItems.Add(, "K" + Format(LVSQL.ListItems.Count + 1, "0000"), tStrArray(i))
            Else
               tItem.SubItems(i - 1) = tStrArray(i)
            End If
         Next i
         Line Input #2, tStr ' 读入一行数据并将其赋予某变量。
      Loop Until EOF(2)
      Close #2
      MsgBox "文件成功导入", vbExclamation, XTTS
   
   Case 1 '保存
      CmnDlg.CancelError = False
      CmnDlg.Flags = cdlOFNOverwritePrompt
      CmnDlg.Filter = "定制文件 (*.qry)|*.qry"
      CmnDlg.DialogTitle = "请输入保存的文件名"
      CmnDlg.ShowSave
      tFileFullName = CmnDlg.FileName
      If tFileFullName = "" Then Exit Sub
   
      Close #2
      Open tFileFullName For Output As #2
      
           Print #2, CbxTypeCode.Text  '档案类型代码
           Print #2, CStr(CbxObject.ListIndex) '对象
           
           Print #2, "显示字段"
           For i = 1 To LVViewField.ListItems.Count
               If LVViewField.ListItems(i).Checked = True Then Print #2, LVViewField.ListItems(i).key
           Next i
           
           Print #2, "显示条件" '+ CStr(LVCondition.ColumnHeaders.Count)
           'Print #2, LVCondition.ListItems.Count
           For i = 1 To LVCondition.ListItems.Count
              For j = 1 To LVCondition.ColumnHeaders.Count
                 If j = 1 Then
                    tStr = "@" + CStr(j) + LVCondition.ListItems(i).Text
                 Else
                    tStr = tStr + "@" + CStr(j) + LVCondition.ListItems(i).SubItems(j - 1)
                 End If
              Next j
              Print #2, tStr
           Next i
                    
           Print #2, "条件" '+ CStr(LVResult.ColumnHeaders.Count)
           'Print #2, LVResult.ListItems.Count
           If CheckFile.Value = 0 Then
                For i = 1 To LVSQL.ListItems.Count
                   For j = 1 To LVSQL.ColumnHeaders.Count
                      If j = 1 Then
                         tStr = "@" + CStr(j) + LVSQL.ListItems(i).Text
                      Else
                         tStr = tStr + "@" + CStr(j) + LVSQL.ListItems(i).SubItems(j - 1)
                      End If
                   Next j
                   Print #2, tStr
                Next i
           Else
                Dim tFileID As String
                tStr = ""
                For i = 1 To LVResult.ListItems.Count
                   If LVResult.ListItems(i).Checked = True Then
                      Call GetValue(tFileID, "file_id", LVResult.ListItems(i).key)
                      tStr = tStr + tFileID + ","
                   End If
                Next i
                tStr = RemoveString(tStr, ",", 2)
                If CbxObject.Text = "文件" Then
                   Print #2, "@1@2@3file_id@4in@5(" + tStr + ")@6"
                Else
                   Print #2, "@1@2@3volume_id@4in@5(" + tStr + ")@6"
                End If
           End If
      Close #2
      MsgBox "文件保存成功", vbExclamation, XTTS
      
      Call SaveEventLog("6016", 0, CbxTypeCode.Text, "", "定制查询文件" + tFileFullName)

   Case 3 '执行
      LVResult.ListItems.Clear
      Call SBarInit

      If LVResult.ColumnHeaders.Count < 1 Then
         MsgBox "您没有选中可显示的字段，请重新选择", vbExclamation, XTTS
         Exit Sub
      End If
      
      If LVCondition.ListItems.Count < 1 Then
         MsgBox "您没有输入查询条件或是输入的查询条件不正确，请重新输入", vbExclamation, XTTS
         Exit Sub
      End If
      
      For i = 1 To LVResult.ColumnHeaders.Count
         Call GetValue(tFieldName, "field_name", LVResult.ColumnHeaders(i).key)
         tSql = tSql + tFieldName + " as " + Trim(LVResult.ColumnHeaders(i).Text) + ","
      Next i
      
      If tSql = "" Then
         MsgBox "您没有选择显示的字段或是选择的显示字段不正确，请重新输入", vbExclamation, XTTS
         Exit Sub
      End If
      
      tSql = "select " + RemoveString(tSql, ",", 0)
      If CbxObject.ListIndex = 0 Then '文件
        tSql = tSql + " ,file_id as id from file_" + gTypeCode(CbxTypeCode.ListIndex + 1) + " where "
        LVResult.Tag = "0" '表类型标志
      Else '案卷，盒
        tSql = tSql + ",volume_id as id from volume_" + gTypeCode(CbxTypeCode.ListIndex + 1) + " where "
        LVResult.Tag = "1" '表类型标志
      End If
      For i = 1 To LVSQL.ListItems.Count
         tWhereStr = tWhereStr + " " + LVSQL.ListItems(i).Text
         For j = 1 To LVSQL.ColumnHeaders.Count - 1
            tWhereStr = tWhereStr + " " + LVSQL.ListItems(i).SubItems(j)
         Next j
         'Debug.Print tWhereStr
      Next i
      
      If tWhereStr = "" Then
         MsgBox "您没有输入查询条件或是输入的查询条件不正确，请重新输入", vbExclamation, XTTS
         Exit Sub
      End If
      tWhereStr = RemoveString(tWhereStr, "and", 0)
      tWhereStr = RemoveString(tWhereStr, "or", 0)
      
      Set gRst = gDbs.OpenRecordset(tSql + tWhereStr)
      If gRst.EOF Then
         MsgBox "没有符合条件的查询结果", vbExclamation, XTTS
         Exit Sub '没有结果集
      End If
      gRst.MoveLast
      gRst.MoveFirst
      SBar.Panels(3).Text = "当前记录数：" + ConvertNull(gRst.RecordCount) + "条"
      'LVResult.Tag =""
      
      While Not gRst.EOF
        For i = 1 To LVResult.ColumnHeaders.Count
         Call GetValue(tFieldName, "field_name", LVResult.ColumnHeaders(i).key)
         Call GetValue(t_Dict_Type, "dict_type", LVResult.ColumnHeaders(i).key)
         
         If IsNull(gRst.Fields(LVResult.ColumnHeaders(i).Text)) Then
            tFieldValue = ""
         Else
            tFieldValue = ConvertNull(gRst.Fields(LVResult.ColumnHeaders(i).Text))
         End If
         
         If i = 1 Then
            Set tItem = LVResult.ListItems.Add(, "LV @I " + ConvertNull(gRst.Fields("id")) + " @P " + gTypeCode(CbxTypeCode.ListIndex + 1), _
                ConvertFieldValue(tFieldValue, CInt(t_Dict_Type), tFieldName, CInt(LVResult.Tag)))
         Else
            tItem.SubItems(i - 1) = ConvertFieldValue(tFieldValue, CInt(t_Dict_Type), tFieldName, CInt(LVResult.Tag))
         End If
        Next i
        SBar.Panels(2).Text = "进度：" + Format(gRst.AbsolutePosition / gRst.RecordCount, "0.00%")
        gRst.MoveNext
      Wend
      SBar.Panels(2).Text = "进度：完成"
      
   Case 5
      CmdDel.Value = True
   Case 6
      CmdDelAll.Value = True
End Select

Exit Sub

Err:
End Sub

Private Sub m_Query_Type_Do_Click(Index As Integer)
On Error GoTo Err
Dim i As Integer
For i = 0 To m_Query_Type_Do.Count - 1
      m_Query_Type_Do(i).Checked = False
Next i
m_Query_Type_Do(Index).Checked = False
CbxObject.ListIndex = Index
Exit Sub
Err:
End Sub

Private Sub m_Type_Code_Do_Click(Index As Integer)
On Error GoTo Err
Dim i As Integer
For i = 0 To m_Type_Code_Do.Count - 1
      m_Type_Code_Do(i).Checked = False
Next i
m_Type_Code_Do(Index).Checked = False

CbxTypeCode.ListIndex = Index
Err:
End Sub

Private Sub Pic1_Resize()
On Error GoTo Err
Dim tMinWidth As Single
Dim tMinHeight As Single
If Pic1.Width < 3000 Then
   tMinWidth = 3000
Else
   tMinWidth = Pic1.Width
End If
If Pic1.Height < 2000 Then
   tMinHeight = 2000
Else
   tMinHeight = Pic1.Height
End If
Label1.Move gBorderWidth, gBorderWidth + 120
Label2.Move gBorderWidth, Label1.Top + 360

CbxTypeCode.Move Label1.Left + Label1.Width + gBorderWidth, gBorderWidth, tMinWidth - (Label1.Left + Label1.Width + 2 * gBorderWidth)
CbxObject.Move CbxTypeCode.Left, CbxTypeCode.Top + CbxTypeCode.Height + gBorderWidth, CbxTypeCode.Width
'Frame1.Move gBorderWidth, CbxObject.Top + CbxObject.Height + gBorderWidth + 60, tMinWidth - 140, tMinHeight - CbxObject.Top - CbxObject.Height - 200
CmdSel(0).Move gBorderWidth, CbxObject.Top + CbxObject.Height + gBorderWidth + 60
CmdSel(1).Move CmdSel(0).Left + CmdSel(0).Width + gBorderWidth, CmdSel(0).Top

LVViewField.Height = Pic1.Height - (CmdSel(1).Top + CmdSel(1).Height) - 2 * gBorderWidth
LVViewField.Move gBorderWidth, CmdSel(0).Top + CmdSel(0).Height + (Pic1.Height - CmdSel(0).Height - CmdSel(0).Top - LVViewField.Height) / 2, Pic1.Width - 2 * gBorderWidth

CheckFile.Move Pic1.Width - gBorderWidth - CheckFile.Width, CmdSel(0).Top
Err:
End Sub

Private Sub Pic2_Resize()
On Error GoTo Err
Dim tMinWidth As Single
If Pic2.Width > 6000 Then
   tMinWidth = Pic2.Width
Else
   tMinWidth = 6000
End If
Label3.Move gBorderWidth, gBorderWidth, tMinWidth - 2 * gBord