frmfilereg.frm

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

'初始化控件大小
CalMain(Index).Width = CalMain(0).Width
CalMain(Index).Height = CalMain(0).Height

If IsDate(MaskRQ(Index).Text) = False Then
   CalMain(Index).Value = Date
Else
   CalMain(Index).Value = CDate(MaskRQ(Index).Text)
End If

'确定控件位置
'在MaskRQ的左或右
If MaskRQ(Index).Container.Width - MaskRQ(Index).Left > CalMain(Index).Width Then
   tHPos = 1
Else
   tHPos = 0
End If

'在MaskRQ的上或下
If MaskRQ(Index).Container.Height - MaskRQ(Index).Top - MaskRQ(Index).Height > CalMain(Index).Height Then
   tVPos = 1
Else
   tVPos = 0
End If

Set CalMain(Index).Container = CmdRQ(Index).Container
If tVPos = 1 Then '在下
   CalMain(Index).Top = MaskRQ(Index).Top + MaskRQ(Index).Height + 600
Else '在上
   If MaskRQ(Index).Top - CalMain(Index).Height > 0 Then
      CalMain(Index).Top = MaskRQ(Index).Top - CalMain(Index).Height
   Else
      CalMain(Index).Top = 0
   End If
End If
If tHPos = 1 Then '在右
   CalMain(Index).Left = MaskRQ(Index).Left
Else '在左
   If CmdRQ(Index).Left + CmdRQ(Index).Width - CalMain(Index).Width > 0 Then
      CalMain(Index).Left = CmdRQ(Index).Left + CmdRQ(Index).Width - CalMain(Index).Width
   Else
      CalMain(Index).Left = 0
   End If
End If
Set CalMain(Index).Container = CmdRQ(Index).Container
CalMain(Index).Visible = True
CalMain(Index).SetFocus
Exit Sub
Err:
    Call MsgErr("日期显示", "2002", "", False, LXGLY, Err.Description)
End Sub


'初始化变量
Private Sub Form_Load()
On Error GoTo Err
Dim i As Integer

TabMain.TabCaption(0) = ""
TabMain.TabCaption(1) = ""
TabMain.TabHeight = 0.1

gCtlDistance = 60
gLabelWidth = 735
gLabelVDistance = 60
gLabelHeight = 255
gCmdWidth = CbxMain(0).Height

TabMain.TabVisible(1) = False
CmdPre.Visible = False
CmdNext.Visible = False
TabMain.TabCaption(0) = ""
TabMain.TabCaption(1) = ""
CalMain(0).Width = 4000
CalMain(0).Height = 2000
Me.Show
Me.WindowState = 2
gTabWidth = Me.ScaleWidth - gCtlDistance * 2
gBaseWidth = (gTabWidth - gCtlDistance) / 3
gBaseHeight = gCtlDistance + CbxMain(0).Height
Exit Sub
Err:
   Call MsgErr("初始化", "2003", "", False, LXGLY, Err.Description)
End Sub

Private Sub LVFile_DblClick()
On Error GoTo Err
Dim tTypeCode As String
Dim tFileID As String
Dim rRights As Integer
Dim rEffectiveTime As String
Dim rExpireTime As String
Dim rMaxRights As Integer
Dim rHasRight As Integer
Dim Rtncode  As String

Dim fs As FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")

Call GetValue(tTypeCode, "type_code", FrmFileReg.Tag)
Call GetValue(tFileID, "file_id", FrmFileReg.Tag)

If LVFile.SelectedItem Is Nothing Then Exit Sub

If Dir(App.Path + "\temp", vbDirectory) = "" Then
   MkDir App.Path + "\temp"
End If
'FileCopy LVFile.Tag + "\" + LVFile.SelectedItem.Text, _
         App.Path + "\temp\" + LVFile.SelectedItem.Text
If Dir(App.Path + "\" + LVFile.SelectedItem.Text) <> "" Then fs.DeleteFile App.Path + "\" + LVFile.SelectedItem.Text, True
's2文件
If LCase(Right(Trim(LVFile.SelectedItem.Text), 3)) = ".s2" Then
   'FileCopy LVFile.Tag + "\" + LVFile.SelectedItem.Text, _
         App.Path + "\" + LVFile.SelectedItem.Text
   fs.CopyFile LVFile.Tag + "\" + LVFile.SelectedItem.Text, App.Path + "\" + LVFile.SelectedItem.Text, True
   Shell App.Path + "\Disp_s2.exe " + Mid(LVFile.SelectedItem.Text, 1, Len(LVFile.SelectedItem.Text) - 3), vbNormalFocus
   DoEvents
Else '其他文件
   If OpenFile(LVFile.Tag + "\" + LVFile.SelectedItem.Text) = False Then
      Call UserSelFile(LVFile.Tag + "\" + LVFile.SelectedItem.Text)
   End If
End If

Exit Sub
Err:
   Call MsgErr("显示文件", "2004", "", False, LXGLY, Err.Description)
End Sub

Private Sub LVFile_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 2 Then Exit Sub
If LVFile.SelectedItem Is Nothing Then Exit Sub
Me.PopupMenu mnupop
End Sub

Private Sub mnu_open_Click()
Call LVFile_DblClick
End Sub

Private Sub PicCmd_Resize()
On Error GoTo Err

CmdCancel.Move PicCmd.Width - gCtlDistance - CmdCancel.Width, (PicCmd.Height - CmdCancel.Height) / 2

CmdPre.Move Me.ScaleWidth / 2 - CmdPre.Width, (PicCmd.Height - CmdPre.Height) / 2
CmdNext.Move Me.ScaleWidth / 2, (PicCmd.Height - CmdPre.Height) / 2
Err:
End Sub

'###################################################################################
'添加属性页 '未使用
'###################################################################################
Public Sub AddTab()
TabMain.TabVisible(1) = True
TabMain.TabsPerRow = 2
CmdPre.Visible = True
CmdNext.Visible = True
End Sub

'###################################################################################
'初始化窗体
'参数：pTypeCode 文件类型 p_Operate_Type 0增加 1修改 2浏览 操作类型 pFileID 显示的文件ID
'返回：Boolean
'###################################################################################
Public Sub FrmInit(pTypeCode As String, p_Operate_Type As String, ByVal pFileID As String)
On Error GoTo Err

Dim tTag As String '记录 字段名称，自定义数据类型，数据字典类型,文件ID
Dim t_End_Height As Single '录入字段终止高度
Dim i As Integer
Dim tErrDes As String
Dim tFileStatus As String
Dim rT1 As String '时间变量
Dim rT2 As String '时间变量
Dim rMaxRights As Integer '文件最高权限
Dim rHasRight As Integer '是否有权限
Dim Rtncode As String '返回值
Dim tFlag2 As Boolean '是否可以修改权限标志
Dim tFlag1 As Boolean '是否可以补传文件标志
Dim tRootAvaliable As Boolean '根路径是否可用

Dim tRst

'获取根路径
If g_Root_Path = "" Then
   'Set gRst = gDbs.OpenRecordset("select * from root_table where root_id=1 and root_status=0")
   'If Not gRst.EOF Then g_Root_Path = RemoveString(gRst.Fields("root_path"), "\", 2)
   g_Root_Path = gCDPath
End If

tErrDes = "控件位置"
LblTitle.Move gCtlDistance, gCtlDistance, Me.ScaleWidth - 2 * gCtlDistance

'调整tab,piccmd位置
TabMain.Move gCtlDistance, LblTitle.Top + LblTitle.Height + gCtlDistance, _
             Me.ScaleWidth - gCtlDistance * 2, _
             (Me.ScaleHeight - LblTitle.Height - LblTitle.Top - gCtlDistance) * 0.92
PicCmd.Move 0, TabMain.Top + TabMain.Height + gCtlDistance, Me.ScaleWidth, _
            Me.ScaleHeight - TabMain.Height - gCtlDistance - LblTitle.Height - LblTitle.Top - gCtlDistance

If pFileID <> "" And pFileID <> "0" Then
   Set gFileRst = gDbs.OpenRecordset("select * from file_" + pTypeCode & _
                     " where file_id=" + pFileID)

   If gFileRst.EOF Then
      pFileID = "0"
   Else
        '文件状态+移交标志+销毁标志+借阅状态
      tFileStatus = Convert_Value(gFileRst.Fields("STATUS"), _
                      0, gFileRst.Fields("STATUS").Type, False, False) & _
                      Convert_Value(gFileRst.Fields("transfer_flag"), _
                      0, gFileRst.Fields("transfer_flag").Type, False, False) & _
                      Convert_Value(gFileRst.Fields("destruction_flag"), _
                      0, gFileRst.Fields("destruction_flag").Type, False, False) & _
                      Convert_Value(gFileRst.Fields("Borrow_STATUS"), _
                      0, gFileRst.Fields("Borrow_STATUS").Type, False, False)
      '未归档文件可以补传
      If gFileRst.Fields("destruction_flag") = 0 And _
        gFileRst.Fields("status") = 0 Then
        tFlag1 = True
      End If
      
   End If
Else
   pFileID = "0"
End If

If pFileID = "0" Then
   tFlag1 = True
ElseIf p_Operate_Type = "0" Or p_Operate_Type = "1" Then
   tFlag2 = True
Else
   tFlag2 = False
End If
tFlag1 = tFlag1 And tFlag2

'设置全局文件关键字
FrmFileReg.Tag = "Frm @P " + pTypeCode + " @I " + pFileID + " @S " + tFileStatus

tErrDes = "固定字段生成"

'文件标题
tTag = "Ctl @F Title @P 3 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文件标题", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, 0, 0, 1, 3, 0, True)
'文件日期
tTag = "Ctl @F File_Date @P 1 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文件日期", tTag, LblMain(LblMain.Count), MaskRQ(MaskRQ.Count), CmdRQ(CmdRQ.Count), 0, gBaseHeight, 1, 1, 0, True)
'办理部门
tTag = "Ctl @F Department_ID @P 4 @D 9 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("办理部门", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, gBaseWidth, gBaseHeight, 1, 1, 0, True)
'保管期限
tTag = "Ctl @F Keep_Term @P 2 @D 3 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("保管期限", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, gBaseWidth * 2, gBaseHeight, 1, 1, 0, True)
'文件载体
tTag = "Ctl @F Media_Type @P 2 @D 4 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文件载体", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, 0, gBaseHeight * 2, 1, 1, 0, True)
'文件密级
tTag = "Ctl @F Secret_Degree @P 2 @D 2 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文件密级", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, gBaseWidth, gBaseHeight * 2, 1, 1, 0, True)
'紧急程度#需要修改
tTag = "Ctl @F Urgency_Degree @P 2 @D 7 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("紧急程度", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, gBaseWidth * 2, gBaseHeight * 2, 1, 1, 0, True)

'分割线
Call SetCtlPos("", "", Nothing, FrameSep(0), Nothing, 0, gBaseHeight * 3, 0, 0, 0, True)

'责任者
tTag = "Ctl @F Duty  @P 2 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("责任者", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, 0, gBaseHeight * 3, 1, 2, 0, True)

'文种
tTag = "Ctl @F File_Kind @P 2 @D 5 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文种", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, 2 * gBaseWidth, gBaseHeight * 3, 1, 1, 0, True)

'文件缩微号
tTag = "Ctl @F Microcopy_No @P 3 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("缩微号", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, 0, gBaseHeight * 4, 1, 1, 0, True)

'文件数量
tTag = "Ctl @F Page_Count @P 4 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文件页数", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, gBaseWidth, gBaseHeight * 4, 1, 1, 0, True)

'全宗名称
tTag = "Ctl @F Fonds_No @P 4 @D 17 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("全宗名称", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, 2 * gBaseWidth, gBaseHeight * 4, 1, 1, 0, True)

'主题词
tTag = "Ctl @F Keywords @P 3 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("主题词", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), CmdMain(CmdMain.Count), 0, gBaseHeight * 5, 1, 3, 0, True)

'备注
tTag = "Ctl @F remark @P 3 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文件备注", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, 0, gBaseHeight * 6, 1, 3, 0, True)

'分类号
tTag = "Ctl @F type_no @P 3 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("分类号", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, 0, gBaseHeight * 7, 1, 2, 0, True)

'支行号
tTag = "Ctl @F branch_id @P 3 @D 8 @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("支行号", tTag, LblMain(LblMain.Count), CbxMain(CbxMain.Count), Nothing, gBaseWidth * 2, gBaseHeight * 7, 1, 1, 0, True)

'文号
tTag = "Ctl @F file_no @P 3 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("文号", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, 0, gBaseHeight * 8, 1, 1, 0, True)

'相关文号
tTag = "Ctl @F relative_file_no @P 3 @D @I " + pFileID + " @N 0 @DF 0"
Call SetCtlPos("相关文号", tTag, LblMain(LblMain.Count), TxtMain(TxtMain.Count), Nothing, gBaseWidth, gBaseHeight * 8, 1, 1, 0, True)

'摘要信息
'tTag = "Ctl @F File_Date @P 1 @D @I " + pFileID + " @N 0"
'Call SetCtlPos("摘要信息", tTag, LblMain(LblMain.Count), RichTxtMain(1), Nothing, 0, gBaseHeight * 6, 2, 3, 0, True)

'分割线
Call SetCtlPos("", "", Nothing, FrameSep(1), Nothing, 0, gBaseHeight * 8, 0, 0, 0, True)

'显示自定义字段
Call CreateForm(pTypeCode, 8 * gBaseHeight, t_End_Height)

'分割线
Call SetCtlPos("", "", Nothing, FrameSep(2), Nothing, 0, t_End_Height, 0, 0, 0, True)
'增加文件列表显示
tErrDes = "显示文件列表"
Call AddControl(LblMain(LblMain.Count))
LblMain(LblMain.Count - 1).Move gCtlDistance, t_End_Height + gCtlDistance + gLabelVDistance, gLabelWidth, gLabelHeight
Set LblMain(LblMain.Count - 1).Container = LineCon(1).Container
LblMain(LblMain.Count - 1).Visible = True
LblMain(LblMain.Count - 1).Caption = "文件列表"
Set LVFile.Container = LineCon(1).Container
LVFile.Move gCtlDistance, t_End_Height + gBaseHeight, TabMain.Width - gCtlDistance * 2, _
            TabMain.Height - (t_End_Height + gCtlDistance + gBaseHeight)
'调整列表宽
For i = 1 To LVFile.ColumnHeaders.Count
   LVFile.ColumnHeaders(i).Width = LVFile.Width / LVFile.ColumnHeaders.Count
Next i

'Call AddFile(gFileRst.Fields("path"), CStr(gFileRst.Fields("root_id")))
Call AddFile(gFileRst.Fields("path"), gCDPath)

Exit Sub
Err:
   Call MsgErr("窗体生成", "2005", tErrDes + "错误", False, LXGLY, Err.Description)
End Sub

'###################################################################################
'以下是自定义档案类型的界面生成
'参数：pTypeCode 文件类型 y 自定义界面生成的其实高度
'返回：Boolean
'###################################################################################
Public Function CreateForm(pTypeCode As String, ByVal Y As Single, p_End_Height As Single) As Boolean
On Error GoTo Err

'1格 宽为gBaseWidth 高为 gBaseHeight
Dim tRdo20 '占用位置为1格的字段结果集
Dim tRdo50 '占用位置为2格的字段结果集
Dim tCurX, tCurY As Single '临时水平、垂直坐标
Dim tErrDes As String '错误描述

Set tRdo50 = gDbs.OpenRecordset("select * from index_file_defination where " & _
             "type_code='" + pTypeCode + "' and data_length<=50 and data_length>20")
Set tRdo20 = gDbs.OpenRecordset("select * from index_file_defination where " & _
             "type_code='" + pTypeCode + "' and (data_length<=20 or data_length is null)")

tCurX = 0
tCurY = Y
tErrDes = "并列显示"
'首先按照 显示1个占位1格的字段 再显示1个占位2格的字段
While Not tRdo50.EOF
   tCurX = 0
   If Not tRdo20.EOF Then
      If SetDefInfo(tRdo20) = False Then GoTo Err
      If InitControl(tCurX, tCurY, 0) = False Then GoTo Err
      tCurX = gBaseWidth
      tRdo20.MoveNext
   End If
   If SetDefInfo(tRdo50) = False Then GoTo Err
   If InitControl(tCurX, tCurY, 0) = False Then GoTo Err
   tCurY = tCurY + gBaseHeight
   tRdo50.MoveNext
Wend

tErrDes = "单独显示"
'再显示其余占位1格的字段
tCurX = 0
While Not tRdo20.EOF
    If SetDefInfo(tRdo20) = False Then GoTo Err
    If InitControl(tCurX, tCurY, 0) = False Then GoTo Err
    tCurX = tCurX + gBaseWidth
    If tCurX = 3 * gBaseWidth Then '换行
       tCurX = 0
       tCurY = tCurY + gBaseHeight
    End If
    tRdo20.MoveNext
Wend

If tCurX <> 0 Then
   tCurX = 0
   tCurY = tCurY + gBaseHeight
End If

tErrDes = "多行显示"
'再显示其余占位大于2格的字段
Set gRst = gDbs.OpenRecordset("select * from index_file_defination where " & _
                "type_code='" + pTypeCode + "' and data_length>50  order by data_length")
While Not gRst.EOF
    If SetDefInfo(gRst) = False Then GoTo Err
    If InitControl(0, tCurY, 0) = False Then GoTo Err