frmmain.frm

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

DoEvents

'显示目录树的第一层
Call ViewTreeRoot(CInt(CmdMain(Index).Tag), CmdCaption)

'调整菜单
For i = 0 To m_Tree.Count - 1
   If i = Index Then
      m_Tree(i).Checked = True
   Else
      m_Tree(i).Checked = False
   End If
Next i

Me.MousePointer = vbDefault
Exit Sub
Err:
   Me.MousePointer = vbDefault
End Sub

Private Sub Form_Activate()
On Error GoTo Err
Call Form_Resize '调整控件位置
Err:
End Sub

Private Sub Form_Load()
On Error GoTo Err
 gConvert_To_Dict = True '是否转换数据字典
 gMax_Convert_Rec = 30000 '转换数据字典最多记录数
 gRfshNode = False '是否单击节点即刷新
Err:
  
End Sub

'调整窗体中控件大小与位置
Private Sub Form_Resize()

If Me.WindowState = 1 Then Exit Sub
If Me.Width < 8000 Then Me.Width = 8000
If Me.Height < 5000 Then Me.Height = 5000
If gWidthRate = 0 Then gWidthRate = 0.3 '水平控件比例
If gHeightRate = 0 Then gHeightRate = 0.6 '垂直控件比例

PicMain.Move 0, Tbar.Height, Me.ScaleWidth * gWidthRate, _
             Me.ScaleHeight - Tbar.Height - SBar.Height

VImgDrag.Move PicMain.Width, PicMain.Top, gBorderWidth, PicMain.Height

PicLV.Move VImgDrag.Width + VImgDrag.Left, PicMain.Top, _
           Me.ScaleWidth - PicMain.Width - gBorderWidth, PicMain.Height

End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error GoTo Err
If MsgBox("你真的要退出系统?", vbQuestion + vbOKCancel, "提示信息") = vbCancel Then
   Cancel = -1
   Exit Sub
End If

Call LogOut(g_User_Info.Login_Name, 0)
Call SaveEventLog("1002", 0, "", "", "用户退出")

Call CloseDB

'清除临时文件
Call RemoveFile(App.Path + "\temp\*.*")
Call RemoveFile(App.Path + "\*.s2")
Call RemoveFile(App.Path + "\*.S2")

End
Err:

End Sub

'列表自动排序
Private Sub LVFile_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

LVFile.Sorted = True

If LVFile.SortKey = ColumnHeader.Index - 1 Then
   
   If LVFile.SortOrder = lvwAscending Then
      LVFile.SortOrder = lvwDescending
   Else
      LVFile.SortOrder = lvwAscending
   End If

Else
   LVFile.SortKey = ColumnHeader.Index - 1
End If

End Sub

'文件修改
Private Sub LVFile_DblClick()
Call ViewFileReg(LVFile, FrmMain, "1")
End Sub

Private Sub LVFile_ItemClick(ByVal Item As MSComctlLib.ListItem)
On Error GoTo Err
Dim tFileStatus As String
Call GetValue(tFileStatus, "status", Item.key) '
Call Init_Pop_Mnu(0, tFileStatus)
Err:
End Sub

Private Sub LVFile_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo Err
If Button <> 2 Then Exit Sub
If LVFile.SelectedItem Is Nothing Then Exit Sub
Me.PopupMenu m_File
Err:
End Sub

Private Sub LVVolume_Click()
On Error GoTo Err
If gLVVolumeMButton <> 1 Then Exit Sub
Me.MousePointer = vbHourglass '设置鼠标
Call List_View_File(LVVolume, LVFile, Nothing, SBar.Panels(2), SBar.Panels(4)) '显示文件列表
Me.MousePointer = vbDefault
Exit Sub
Err:
   Me.MousePointer = vbDefault
End Sub

'列表自动排序
Private Sub LVVolume_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

LVVolume.Sorted = True

If LVVolume.SortKey = ColumnHeader.Index - 1 Then
   
   If LVVolume.SortOrder = lvwAscending Then
      LVVolume.SortOrder = lvwDescending
   Else
      LVVolume.SortOrder = lvwAscending
   End If

Else
   LVVolume.SortKey = ColumnHeader.Index - 1
End If

End Sub

Private Sub LVVolume_DblClick()
Call ViewVolumeReg(LVVolume, FrmMain, "1")
End Sub

Private Sub LVVolume_ItemClick(ByVal Item As MSComctlLib.ListItem)
On Error GoTo Err
Dim tVolume_Status As String
Call GetValue(tVolume_Status, "status", Item.key) '
Call Init_Pop_Mnu(1, tVolume_Status)
Err:
End Sub

Private Sub LVVolume_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
gLVVolumeMButton = Button
End Sub

Private Sub LVVolume_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo Err

Dim tType As String '案卷或盒
If Button <> 2 Then Exit Sub

If LVVolume.SelectedItem Is Nothing Then Exit Sub
Call GetValue(tType, "status", LVVolume.SelectedItem.key)

If Mid(tType, 1, 1) = "0" Then '案卷
   Me.PopupMenu m_Volume
ElseIf Mid(tType, 1, 1) = "1" Then '盒
   Me.PopupMenu m_Box
End If

Err:
End Sub

Private Sub m_Box_Do_Click(Index As Integer)
On Error GoTo Err
Dim tVolume_Status As String '案卷状态
Dim tTypeCode As String '档案类型
Dim tID As String '案卷ID
Dim i As Integer '临时变量
Dim tRtnCode As String
'刷新时用
Dim tIndex As String '节点或项目Index

'If LVVolume.SelectedItem Is Nothing Then Exit Sub

Select Case Index
   Case 0 '案卷浏览
       If LVVolume.SelectedItem Is Nothing Then Exit Sub
       Call ViewVolumeReg(LVVolume, FrmMain, "2")
  
End Select

Call GetValue(tIndex, "NODE_index", LVVolume.Tag)
Set TVMain.SelectedItem = Nothing
Set TVMain.SelectedItem = TVMain.Nodes(CInt(tIndex))
Call TVMain_DblClick
'Call TVMain_NodeClick(TVMain.Nodes(CInt(tIndex)))
   
Exit Sub
Err:

End Sub

Private Sub m_File_Do_Click(Index As Integer)
On Error GoTo Err
Dim i As Integer '临时变量
Dim tFileStatus As String '文件状态
Dim tID As String '文件ID
Dim tTypeCode As String '档案类型

'刷新时用
Dim tIndex As String '节点或项目Index
Dim tList_Type As String '0节点，1项目
Dim tStr As String

If LVFile.ListItems Is Nothing Then Exit Sub

'开始事务

Select Case Index
   Case 0 '浏览
       Call ViewFileReg(LVFile, FrmMain, "2")

End Select

Call GetValue(tList_Type, "type", LVFile.Tag)

If tList_Type = "1" Then '案卷下文件 对应list_defination下的listtype
   Call GetValue(tIndex, "VOLUME_index", LVFile.Tag)
   LVVolume.ListItems(CInt(tIndex)).Selected = True
   Call LVVolume_Click
ElseIf tList_Type = "2" Then '仅文件 对应list_defination下的listtype
   Call GetValue(tIndex, "NODE_index", LVFile.Tag)
   Set TVMain.SelectedItem = Nothing
   Set TVMain.SelectedItem = TVMain.Nodes(CInt(tIndex))
   Call TVMain_DblClick
   'Call TVMain_NodeClick(TVMain.Nodes(CInt(tIndex)))
End If
Exit Sub
Err:

End Sub

Private Sub m_Help_Do_Click()
FrmAboutMe.Show 1
End Sub


Private Sub m_Tool_Do_Click(Index As Integer)
Select Case Index
   Case 0
      Me.MousePointer = 11
      FrmFind.Show
End Select
Me.MousePointer = 0
End Sub

Private Sub m_Tree_Click(Index As Integer)
CmdMain(Index).Value = True
End Sub

Private Sub m_View_Do_Click(Index As Integer)
Dim i As Integer
Select Case Index
   Case 0, 1, 2, 3
      If gObjectType = 0 Then
         LVFile.View = Index
      ElseIf gObjectType = 1 Then
         LVVolume.View = Index
      End If
      For i = 0 To 3
         If i = Index Then
            m_View_Do(i).Checked = True
         Else
            m_View_Do(i).Checked = False
         End If
      Next i
   Case 5
       If TVMain.SelectedItem Is Nothing Then
          Call FrmInit
       Else
          Call TVMain_DblClick
       End If
End Select
End Sub

Private Sub m_Volume_Do_Click(Index As Integer)
On Error GoTo Err
Dim tVolume_Status As String '案卷状态
Dim tTypeCode As String '档案类型
Dim tID As String '案卷ID
Dim i As Integer '临时变量
Dim tRtnCode As String
'刷新时用
Dim tIndex As String '节点或项目Index

'If LVVolume.SelectedItem Is Nothing Then Exit Sub


Select Case Index
   Case 0 '案卷浏览
       If LVVolume.SelectedItem Is Nothing Then Exit Sub
       Call ViewVolumeReg(LVVolume, FrmMain, "2")
  
End Select


Call GetValue(tIndex, "NODE_index", LVVolume.Tag)
Set TVMain.SelectedItem = Nothing
Set TVMain.SelectedItem = TVMain.Nodes(CInt(tIndex))
Call TVMain_DblClick
'Call TVMain_NodeClick(TVMain.Nodes(CInt(tIndex)))
   
Exit Sub
Err:
End Sub

Private Sub mnu_exit_Click()
Unload Me
End Sub

Private Sub mnu_inf_Click()
Dim tStr As String
tStr = Dir(gCDPath + "\data\*.qry")
If tStr = "" Then
   MsgBox "当前目录没有定制的查询文件", vbExclamation, XTTS
   Exit Sub
End If
Call FrmLoadQueryFile.FrmInit(gCDPath + "\data\" + tStr, True)
End Sub

Private Sub mnu_lock_Click()
Me.Visible = False
FrmLock.Show 1
End Sub

Private Sub mnu_sel_Click()
Dim tCDPath As String

tCDPath = gCDPath
   
FrmSelCDPath.Show 1
If gIsPath = False Then
   gCDPath = tCDPath
Else
   gTreeDef = False
End If

End Sub

Private Sub mnu_tree_Click()
On Error GoTo Err
Dim fs As FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")

If gTreeDef = False Then  '目录树已经自定义过

    If Dir(gCDPath + "\data\DiskDB.mdb") = "" Then
       MsgBox "当前所选路径不可用，请重新选择", vbExclamation, XTTS
       Call mnu_sel_Click
       Exit Sub
    End If
    
    fs.CopyFile gCDPath + "\data\DiskDB.mdb", App.Path + "\DiskDB.mdb", True
    fs.GetFile(App.Path + "\DiskDB.mdb").Attributes = Normal
End If

gDbs.Close
Set gDbs = gWrks.OpenDatabase(App.Path + "\DiskDB.mdb", False, False)
gTreeDef = True
Call FrmInit
Call FrmTree.FrmInit
Exit Sub
Err:
   gTreeDef = False
End Sub

'调整PicLV中控件大小与位置
Private Sub PicLV_Resize()

If LVFile.Visible = True Then