frmfilereg.frm

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

    tCurY = tCurY + gDef_Info.VScale * gBaseHeight
    gRst.MoveNext
Wend

p_End_Height = tCurY

CreateForm = True
Exit Function
Err:
   CreateForm = False
   Call MsgErr("自定义字段生成", "2007", tErrDes + "错误", False, LXGLY, Err.Description)
End Function

'###################################################################################
'创建控件并按位置显示
'参数：p_Lbl_Caption控件显示的字段名 p_LabelCtl 显示名称的Label控件
'     p_Main_Ctl显示字段的主控件 p_Cmd_Ctl 允许定义并显示自己的按钮
'     x 显示控件的水平坐标 y 显示控件的垂直坐标
'     p_VScale 控件的垂直大小 p_HScale 控件的水平大小 p_Container_Tab 控件属于的Tab
'     p_Permit_Modefy 是否允许修改
'返回：Boolean
'###################################################################################
Public Function SetCtlPos(p_Lbl_Caption As String, p_Main_Ctl_Tag As String, _
                p_LabelCtl As Label, p_Main_Ctl As Control, p_Cmd_Ctl As CommandButton, _
                ByVal X As Single, ByVal Y As Single, p_VScale As Integer, _
                p_HScale As Integer, p_Container_Tab As Integer, p_Permit_Modefy As Boolean) As Boolean

On Error GoTo Err:

Dim tWidth As Single '临时变量
Dim tHeight As Single
Dim t_Dict_Type As String
Dim tFileID As String
Dim tFieldName As String
Dim t_Data_Type As String
Dim tFieldValue As String
Dim tIsDefined As String
Dim i As Integer
Dim tErrDes As String '错误描述

'添加分割线，直接退出
tErrDes = "添加分割线"
If TypeOf p_Main_Ctl Is Frame Then
   '控件不存在先添加
   If IsControl(p_Main_Ctl) = False Then
      Call AddControl(p_Main_Ctl)
   End If
   p_Main_Ctl.Move gCtlDistance, Y - 60, TabMain.Width - gCtlDistance * 2, 125
   SetCtlPos = True
   Exit Function
End If

tErrDes = "设置关键字"
Call GetValue(tFileID, "FILE_ID", p_Main_Ctl_Tag)
Call GetValue(t_Dict_Type, "DICT_TYPE", p_Main_Ctl_Tag)
Call GetValue(tFieldName, "FIELD_EN_NAME", p_Main_Ctl_Tag)
Call GetValue(t_Data_Type, "Data_Type", p_Main_Ctl_Tag)
Call GetValue(tIsDefined, "Is_Defined", p_Main_Ctl_Tag)

tErrDes = "添加控件"
'控件不存在先添加
If IsControl(p_LabelCtl) = False Then
   Call AddControl(p_LabelCtl)
End If

'标题
p_LabelCtl.Move X + gCtlDistance, Y + gCtlDistance + gLabelVDistance, gLabelWidth, gLabelHeight

'若同时有2页属性页 显示时y有偏差
If TabMain.TabsPerRow > 1 Then Y = Y + 360

'控件不存在先添加
If IsControl(p_Main_Ctl) = False Then
   Call AddControl(p_Main_Ctl)
End If

'控件不存在先添加
If IsControl(p_Cmd_Ctl) = False Then
   Call AddControl(p_Cmd_Ctl)
End If

'设置控件所处属性页
Set p_LabelCtl.Container = LineCon(p_Container_Tab).Container
If p_HScale > 3 Then p_HScale = 3

'计算控件宽度,高度
tWidth = p_HScale * gBaseWidth
tHeight = p_VScale * gBaseHeight

'ComboBox控件无法设置高度
If Not (TypeOf p_Main_Ctl Is ComboBox) Then p_Main_Ctl.Height = tHeight - gCtlDistance

'添加主控件
tErrDes = "设置主控件"
If p_Cmd_Ctl Is Nothing Then '无按钮
   p_Main_Ctl.Move p_LabelCtl.Left + p_LabelCtl.Width + gCtlDistance, _
                   Y + gCtlDistance, tWidth - 2 * gCtlDistance - p_LabelCtl.Width
   p_Main_Ctl.Enabled = p_Permit_Modefy
Else '有按钮
   p_Main_Ctl.Move p_LabelCtl.Left + p_LabelCtl.Width + gCtlDistance, _
                   Y + gCtlDistance, tWidth - 2 * gCtlDistance - p_LabelCtl.Width - gCmdWidth
   p_Cmd_Ctl.Move p_Main_Ctl.Left + p_Main_Ctl.Width, p_Main_Ctl.Top, _
                  gCmdWidth, gCmdWidth
   Set p_Cmd_Ctl.Container = p_LabelCtl.Container
   p_Cmd_Ctl.Visible = True
   p_Main_Ctl.Enabled = p_Permit_Modefy
   p_Cmd_Ctl.Enabled = p_Permit_Modefy
End If

'设置控件所处属性页
Set p_Main_Ctl.Container = p_LabelCtl.Container
p_Main_Ctl.Visible = True
If tIsDefined = "0" Then p_LabelCtl.ForeColor = &HFF0000
p_LabelCtl.Caption = p_Lbl_Caption
p_Main_Ctl.Tag = p_Main_Ctl_Tag

'??????????????若错误则列表无法显示
If tFileID <> "0" And tFieldName <> "" Then
   tFieldValue = Convert_Value(gFileRst.Fields(tFieldName), 0, _
                   gFileRst.Fields(tFieldName).Type, False, False)
End If

'以下进行列表显示处理
tErrDes = "显示列表"
If t_Dict_Type <> "" And TypeOf p_Main_Ctl Is ComboBox Then
    i = -1
    Set gRst = gDbs.OpenRecordset("select * from system_dict where " & _
                    "type=" + t_Dict_Type + " order by code")
    While Not gRst.EOF
       '??????
       p_Main_Ctl.AddItem Trim(gRst.Fields("name"))
       p_Main_Ctl.ItemData(gRst.AbsolutePosition) = CLng(gRst.Fields("code"))
       If Trim(tFieldValue) = Trim(ConvertNull(gRst.Fields("code"))) Then i = gRst.AbsolutePosition
       gRst.MoveNext
    Wend
    p_Main_Ctl.ListIndex = i
ElseIf TypeOf p_Main_Ctl Is MaskEdBox Then
    If IsDate(tFieldValue) Then p_Main_Ctl.Text = Format(CDate(tFieldValue), "yyyy年mm月dd日")
Else
    p_Main_Ctl.Text = tFieldValue
    If tFieldName = "Title" Then
       p_Main_Ctl.ForeColor = &HFF&
       p_Main_Ctl.Font.Name = "黑体"
       p_Main_Ctl.FontSize = 10
    End If
End If


SetCtlPos = True
Exit Function
Err:
   Call MsgErr("显示控件", "2008", tErrDes + "错误", False, LXGLY, Err.Description)
   SetCtlPos = False
End Function

'###################################################################################
'添加控件p_Control为要添加的控件
'###################################################################################
Public Function AddControl(p_Control As Control) As Boolean
On Error GoTo Err
Load p_Control
p_Control.Visible = True
AddControl = True
Exit Function
Err:
End Function

'###################################################################################
'根据结果集设置字段对象，gDef_Info全局变量
'###################################################################################
Public Function SetDefInfo(p_RdoResult) As Boolean
On Error GoTo Err
With p_RdoResult
    If Convert_Value(.Fields("data_length"), 0, .Fields("data_type").Type, False, False) = "" Then
       gDef_Info.Data_Length = 0
    Else
       gDef_Info.Data_Length = CInt(Convert_Value(.Fields("data_length"), 0, .Fields("data_type").Type, False, False))
    End If
    
    If Convert_Value(.Fields("Data_Scale"), 0, .Fields("Data_Scale").Type, False, False) = "" Then
       gDef_Info.Data_Scale = 0
    Else
       gDef_Info.Data_Scale = CInt(Convert_Value(.Fields("Data_Scale"), 0, .Fields("Data_Scale").Type, False, False))
    End If
    If Convert_Value(.Fields("Data_Type"), 0, .Fields("Data_Type").Type, False, False) = "" Then
       gDef_Info.Data_Type = 0
    Else
       gDef_Info.Data_Type = CInt(Convert_Value(.Fields("Data_Type"), 0, .Fields("Data_Type").Type, False, False))
    End If
    gDef_Info.Display_Name = Convert_Value(.Fields("DISPLAY_NAME"), 0, .Fields("DISPLAY_NAME").Type, False, False)
    gDef_Info.Field_Name = Convert_Value(.Fields("Field_Name"), 0, .Fields("Field_Name").Type, False, False)
    gDef_Info.Type_Code = Convert_Value(.Fields("Type_Code"), 0, .Fields("Type_Code").Type, False, False)
    '控件大小
    If gDef_Info.Data_Length <= 20 Then
       gDef_Info.HScale = 1
       gDef_Info.VScale = 1
    ElseIf gDef_Info.Data_Length <= 50 And gDef_Info.Data_Length > 20 Then
       gDef_Info.HScale = 2
       gDef_Info.VScale = 1
    ElseIf gDef_Info.Data_Length <= 100 And gDef_Info.Data_Length > 50 Then
       gDef_Info.HScale = 3
       gDef_Info.VScale = 1
    ElseIf gDef_Info.Data_Length > 100 Then
       gDef_Info.HScale = 3
       gDef_Info.VScale = 2
    End If
    gDef_Info.System_Dict_Type = Convert_Value(.Fields("System_Dict_Type"), 0, .Fields("data_type").Type, False, False)
    gDef_Info.Is_Null = Convert_Value(.Fields("Is_Null"), 0, .Fields("Is_Null").Type, False, False)

End With
SetDefInfo = True
Exit Function
Err:
   Call MsgErr("设置自定义信息", "2009", "", False, LXGLY, Err.Description)
   SetDefInfo = False
End Function

'###################################################################################
'初始化自定义控件
'参数：gDef_Info全局变量 存放显示字段的信息
'     x 显示控件的水平坐标 y 显示控件的垂直坐标 p_Container_Tab 控件属于的Tab
'返回：Boolean
'###################################################################################
Public Function InitControl(ByVal X As Single, ByVal Y As Single, p_Container_Tab As Integer) As Boolean
On Error GoTo Err

Dim tMain_Ctl As Control '显示的主控件
Dim tCmd_Ctl As Control '显示的按钮控件
Dim tTag As String '临时Tag变量

'设置所显示的控件
If gDef_Info.Data_Type = 1 Then '显示日期
   Set tMain_Ctl = MaskRQ(MaskRQ.Count)
   Set tCmd_Ctl = CmdRQ(CmdRQ.Count)
ElseIf gDef_Info.System_Dict_Type <> 0 Then '显示数据字典
   Set tMain_Ctl = CbxMain(CbxMain.Count)
Else '显示TXT
   If gDef_Info.Data_Length <= 100 Then
      Set tMain_Ctl = TxtMain(TxtMain.Count)
   Else
      Set tMain_Ctl = TxtMain(RichTxtMain.Count)
   End If
End If

With gDef_Info
    '显示控件
    tTag = "Ctl @F " + CStr(.Field_Name) & _
               "@P" + CStr(.Data_Type) & _
               "@D" + CStr(.System_Dict_Type) & _
               "@N" + CStr(.Is_Null)
    Call SetCtlPos(.Display_Name, tTag, LblMain(LblMain.Count), tMain_Ctl, _
                   tCmd_Ctl, X, Y, .VScale, .HScale, p_Container_Tab, True)
End With
InitControl = True
Exit Function
Err:
   Call MsgErr("控件初始化", "2010", "", False, LXGLY, Err.Description)
   InitControl = False
End Function

'###################################################################################
'在LVFile中显示文件列表文件
'p_Root_Path文件根路径  若为空则文件路径取p_File_Path
'p_File_Path 文件相对路径
'###################################################################################
Public Function AddFile(p_File_Path As String, p_Root_Path As String) As Boolean
On Error GoTo Err
Dim t_File_Name As String

Dim fs As FileSystemObject
Dim f As Folder
Dim fc As Files
Dim f1 As File
Dim tListItem As ListItem
Dim tErrDes As String

tErrDes = "设置文件路径"
Set fs = CreateObject("Scripting.FileSystemObject")
If p_Root_Path <> "" Then
   If IsNumeric(p_Root_Path) = True Then '参数为root_id
      Set gRst = gDbs.OpenRecordset("select * from root_table where " & _
                      "root_id=" + p_Root_Path)
      If gRst.EOF = True Then GoTo Err
      Set f = fs.GetFolder(RemoveString(Trim(gRst.Fields("root_path")), "\", 2) + "\" + p_File_Path)
   Else
      Set f = fs.GetFolder(RemoveString(p_Root_Path, "\", 2) + "\" + p_File_Path)
   End If
Else
   Set f = fs.GetFolder(p_File_Path)
End If
LVFile.Tag = f.Path  '设置文件路径
Set fc = f.Files

tErrDes = "显示文件"
LVFile.ListItems.Clear
For Each f1 In fc
    Set tListItem = LVFile.ListItems.Add(, f1.Path, f1.Name)
    tListItem.SubItems(1) = f1.Type
    
    If f1.Size > 1000000 Then
       tListItem.SubItems(2) = Format(CStr(CSng(f1.Size) / 1024 / 1024), "0.0") + "M"
    Else
       tListItem.SubItems(2) = Format(CStr(CSng(f1.Size) / 1024), "0.0") + "K"
    End If
    tListItem.SubItems(3) = f1.DateCreated
    tListItem.SubItems(4) = f1.DateLastAccessed
     
Next

AddFile = True
Exit Function
Err:
   Call MsgErr("显示文件列表", "2011", tErrDes + "错误", False, LXGLY, Err.Description)

End Function

'###################################################################################
'调用系统默认刻执行文件打开电子文档 pFileName 为要打开的文件全路经
'###################################################################################
Public Function OpenFile(pFileName As String) As Boolean
On Error GoTo Err
Dim tStr As String
Dim tStr1 As String
tStr1 = GetSysPath
If InStrRev(pFileName, ".") = 0 Then GoTo Err
tStr = Mid(pFileName, InStrRev(pFileName, "."))
If GetRegVal("software\classes\" + tStr, tStr) = False Then GoTo Err
If GetRegVal("software\classes\" + tStr + "\shell\open\command", tStr) = False Then GoTo Err
tStr = Replace(Trim(tStr), """", "")
tStr = Replace(tStr, "%1", pFileName)
tStr = Replace(tStr, "%L", pFileName)
tStr = Replace(tStr, "%SystemRoot%", tStr1)

If InStr(1, LCase(tStr), "iexplore") <> 0 Then
   If gIEPath <> "" Then
      Shell gIEPath + " " + pFileName, vbNormalFocus
   Else
      Shell tStr, vbNormalFocus
   End If
Else
   If InStr(1, tStr, pFileName) = 0 Then tStr = tStr + " " + pFileName
   Shell tStr, vbNormalFocus
End If
OpenFile = True
Exit Function
Err:
   OpenFile = False
End Function

'###################################################################################
'用户手工选择刻执行文件打开电子文档 pFileName 为要打开的文件全路径
'###################################################################################
Public Function UserSelFile(pFileName As String) As Boolean
On Error GoTo Err
Dim tFileFullName As String
Dim tStr As String

    CmnDlg.CancelError = False
    CmnDlg.Filter = "可执行文件 (*.exe)|*.exe|" & _
                    "所有文件 (*.*)|*.*"
    CmnDlg.DialogTitle = "请选择浏览文件的可执行文件"
    CmnDlg.ShowOpen
    tFileFullName = CmnDlg.FileName
    If tFileFullName = "" Then Exit Function
    Shell tFileFullName + " " + pFileName, vbNormalFocus
    
    If MsgBox("是否始终用该文件打开", vbQuestion + vbYesNo, XTTS) = vbYes Then
       tStr = Mid(pFileName, InStrRev(pFileName, ".") + 1)
       Call FileRegister(tStr, tFileFullName)
    End If

UserSelFile = True
Exit Function
Err:
   UserSelFile = False
End Function

Private Sub mnu_user_sel_Click()
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

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

Call UserSelFile(LVFile.Tag + "\" + LVFile.SelectedItem.Text)

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