frmloadqueryfile.frm

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

         SubItemIndex    =   4
         Text            =   "字段值"
         Object.Width           =   6174
      EndProperty
      BeginProperty ColumnHeader(6) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
         SubItemIndex    =   5
         Key             =   "rk"
         Object.Width           =   706
      EndProperty
   End
End
Attribute VB_Name = "FrmLoadQueryFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim gTypeCode() As String  '全局档案类型数组，对应cbxtypecode中的选项

Private Sub CmdOK_Click()
Unload Me
End Sub

'#####################################################################################
'窗体初始化
'pFilePath 查询文件路径 pViewFlag 是否显示窗体
'#####################################################################################
Public Sub FrmInit(pFilePath As String, pViewFlag As Boolean)

On Error GoTo Err
Dim tTempPos As Integer
Dim tCount As Integer
Dim i As Integer

tTempPos = InStr(1, StrReverse(pFilePath), "\")
If tTempPos <> 0 Then
   TxtFileName.Text = StrReverse(Mid(StrReverse(pFilePath), 1, tTempPos - 1))
Else
   TxtFileName.Text = ""
End If
'TxtFileName = pFilePath

CbxObject.ListIndex = 0

Set gRst = gDbs.OpenRecordset("select count(*) from archive_type")
If Not gRst.EOF Then tCount = gRst.Fields(0)

Set gRst = gDbs.OpenRecordset("select * from archive_type order by type_code")
CbxTypeCode.Clear
If Not gRst.EOF Then ReDim gTypeCode(1 To tCount) As String
i = 1
While Not gRst.EOF
   CbxTypeCode.AddItem Trim(ConvertNull(gRst.Fields("Type_Name")))
   gTypeCode(gRst.AbsolutePosition + 1) = Trim(ConvertNull(gRst.Fields("type_code")))
   'If grst.AbsolutePosition > 1 Then Load m_Type_Code_Do(grst.AbsolutePosition - 1)
   gRst.MoveNext
Wend

If CbxTypeCode.ListCount > 1 Then
   CbxTypeCode.ListIndex = 0
   'Call AddViewField(gTypeCode(1), CbxObject.ListIndex)
   'Call AddQueryField(gTypeCode(1), CbxObject.ListIndex)
End If
If pViewFlag = True Then
   Call LoadQueryFile(pFilePath)
   FrmLoadQueryFile.Show 1
End If

LVCondition.ListItems.Clear
LVSQL.ListItems.Clear

Err:
End Sub

'#####################################################################################
'加载指定的.qry文件并检验格式 pFilePath.qry文件的绝对路径
'#####################################################################################
Public Function LoadQueryFile(pFilePath As String) As Boolean
Dim tSql As String
Dim tWhereStr As String
Dim i, j As Integer
Dim t_Type_Code As String
Dim t_Field_Name As String '字段名称
Dim t_Dict_Type As String '数据字典
Dim tItem As ListItem
Dim t_Field_Value 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

tFileFullName = pFilePath
If tFileFullName = "" Then GoTo Err

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) '显示字段
   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

LoadQueryFile = True
Exit Function
Err:
   If EOF(2) Then
      LoadQueryFile = True
   Else
      LoadQueryFile = False
   End If
End Function

'#####################################################################################
'获取当前显示对应的sql语句 rQueryStr返回的查询语句 rTableName返回查询的表名 rWhereStr返回查询语句中的where子句
'#####################################################################################
Public Function GetQueryStr(rQueryStr As String, rTableName As String, rWhereStr As String) As Boolean
Dim tSql As String
Dim tWhereStr As String
Dim i As Integer
Dim j As Integer

On Error GoTo Err

      tSql = "select * "
      
      If CbxObject.ListIndex = 0 Then '文件
        tSql = "select * from file_" + gTypeCode(CbxTypeCode.ListIndex + 1) + " where "
        'LVResult.Tag = "0" '表类型标志
      Else '案卷，盒
        tSql = "select * 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 Function
      End If
      tWhereStr = RemoveString(tWhereStr, "and", 0)
      tWhereStr = RemoveString(tWhereStr, "or", 0)
      
      rWhereStr = tWhereStr
      rQueryStr = tSql + tWhereStr
      If CbxObject.ListIndex = 0 Then '文件
         rTableName = "file_" + gTypeCode(CbxTypeCode.ListIndex + 1)
      Else
         rTableName = "volume_" + gTypeCode(CbxTypeCode.ListIndex + 1)
      End If
GetQueryStr = True
Exit Function
Err:
   GetQueryStr = False
End Function

Private Sub CmdSel_Click()
Dim tFileFullName As String
Dim tTempPos As Integer
Dim tStr As String
Dim fs As FileSystemObject
Dim f As File
Set fs = CreateObject("Scripting.FileSystemObject")

      CmnDlg.CancelError = False
      CmnDlg.Filter = "定制文件 (*.qry)|*.qry"
      CmnDlg.DialogTitle = "请选择定制的查询文件"
      CmnDlg.FileName = gCDPath + "\data\*.qry"
      CmnDlg.ShowOpen
      tFileFullName = CmnDlg.FileName
      If tFileFullName = "" Then Exit Sub
      
      tTempPos = InStr(1, tFileFullName, " ")
      If Dir(tFileFullName) = "" Then Exit Sub
      If tTempPos = 0 And tFileFullName <> "" Then '单个文件
         Set f = fs.GetFile(tFileFullName)
         '文件格式检验
         Call FrmLoadQueryFile.FrmInit(f.Path, True)
         
      Else '多个文件
         MsgBox "请选则单个文件", vbExclamation, XTTS
         Exit Sub
         
      End If
End Sub