frmvolumereg.frm

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

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)

If pType = 1 Then
   Call List_View_File2(FrmFind.LVResult, LVFile, Nothing, Nothing, Nothing)
Else
   Call List_View_File(FrmMain.LVVolume, LVFile, Nothing, Nothing, Nothing)
End If

If tObjString = "盒" Then tObjString = "档案" + tObjString
Me.Caption = tObjString + "信息"
LblTitle.Caption = tObjString + "信息"

Exit Sub
Err:
   Call MsgErr("窗体生成", "3005", 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_Volume_defination where type_code='" + pTypeCode + "' and data_length<=50 and data_length>20")
Set tRdo20 = gDbs.OpenRecordset("select * from index_Volume_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

tErrDes = "多行显示"
If tCurX <> 0 Then
   tCurX = 0
   tCurY = tCurY + gBaseHeight
End If

'再显示其余占位大于2格的字段
Set gRst = gDbs.OpenRecordset("select * from index_Volume_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
    tCurY = tCurY + gDef_Info.VScale * gBaseHeight
    gRst.MoveNext
Wend

p_End_Height = tCurY

CreateForm = True
Exit Function
Err:
   Call MsgErr("自定义字段生成", "3007", tErrDes + "错误", False, LXGLY, Err.Description)
   CreateForm = False
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 tVolumeID 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(tVolumeID, "Volume_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
p_LabelCtl.Caption = p_Lbl_Caption
If tIsDefined = "0" Then p_LabelCtl.ForeColor = &HFF0000
p_Main_Ctl.Tag = p_Main_Ctl_Tag

'??????????????若错误则列表无法显示
If tVolumeID <> "0" And tFieldName <> "" Then tFieldValue = Convert_Value(gVolumeRdoRst.Fields(tFieldName), 0, gVolumeRdoRst.Fields(tFieldName).Type, False, False)
'以下进行列表显示处理
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("显示控件", "3008", tErrDes + "错误", False, LXGLY, Err.Description)
   SetCtlPos = False
End Function

'###################################################################################
'添加控件
'###################################################################################
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:
AddControl = False
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("System_Dict_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("设置自定义信息", "3009", "", 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 = RichTxtMain(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) & _
               "@DF 1"
    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("控件初始化", "3010", "", False, LXGLY, Err.Description)
   InitControl = False
End Function