++

VB开发的ERP系统

    
    FillImageCombo Imgcbo_Title, "Khgl_TitleCompute", 1
           
    Sqlstr = "SELECT TitleCode,titleName From Kh_Title where (endflag=1  and CloseFlag=0 and CreateTime=(select max(createTime) from kh_title where endflag=1  and CloseFlag=0))"
    Set RecExist = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    If Not RecExist.EOF Then
        If Len(Trim(RecExist.Fields("titleName"))) > 0 Then
            Imgcbo_Title.Text = RecExist.Fields("titleName")
        End If
    End If
    
    str_TitleCode = GetComboKey(Imgcbo_Title, 0)
    
End Function

Private Sub Imgcbo_Title_Click()
    str_TitleCode = GetComboKey(Imgcbo_Title, 0)
    
        '生成查询结果
    Call Sub_Query
    
    '设置网格
    ShowRecord
    
    '生成查询结果，填充评价标准
    
    Call Sub_QuerySub
    
End Sub
Public Function ShowRecord()                '设置网格

    '定义变量
    Dim cn As Connection
    Dim s As String
    Dim rs As New ADODB.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim iFixedCols As Integer
    Dim iBeginCol As Integer
    Dim maxrows  As Integer             '考核要素最大行数
    
    If NullFlag = False Then Exit Function
    
    Set cn = Cw_DataEnvi.DataConnect
    iFixedCols = 4
    
    ReDim sItem(2) '字段属性
    sItem(0).ItemCode = 0
    sItem(0).ItemName = "考核要素编码"
    
    sItem(1).ItemCode = 0
    sItem(1).ItemName = "考核指标"
    
    sItem(2).ItemCode = 0
    sItem(2).ItemName = "考核要素名称"
    
    '初始化各种变量
    iBeginCol = GridInf(1)  '数据开始行数
    
    '生成查询语句,取考核要素对应量化规则对应的量化规则明细的记录数的最大值，作为动态增加的列数
    maxrows = 0
    For Jsqte = WglrGrid.FixedRows To WglrGrid.Rows
        
        If rs.State = 1 Then rs.Close
        
        s = "select  1   From Kh_GauList  " & Chr(10) _
            & " where CheckCode ='" & strFactor(Jsqte, 2) & "'"
            
        Set rs = cn.Execute(s)
        If rs.RecordCount > maxrows Then
            maxrows = rs.RecordCount
        End If
    Next Jsqte
    
    If maxrows < 2 Then maxrows = 2   '分值规则最多两列
    
    For Jsqte = 1 To maxrows
        ReDim Preserve sItem(UBound(sItem) + 1)
        sItem(UBound(sItem)).ItemName = "评价标准"
    Next Jsqte
    
    '网格再增加2列，用于填充考核数据
    ReDim Preserve sItem(UBound(sItem) + 1)
    sItem(UBound(sItem)).ItemName = "初评"

   
    With Me.WglrGrid
        '初始化网格
        .Redraw = False
        .Cols = UBound(sItem) + 2
        .FixedCols = iFixedCols
        '设置行标题
        For i = iFixedCols To .Cols - 1
            .TextMatrix(0, i) = sItem(i - 1).ItemName
            .ColWidth(i) = 1000                         '宽度
            .ColAlignment(i) = flexAlignRightCenter     '数据右对齐
            .FixedAlignment(i) = 4                      '列标题居中
        Next i
    
        For i = .FixedRows To .Rows - 1
            .RowHeight(i) = GridInf(2)
            .Cell(flexcpBackColor, i, .FixedCols, i, .Cols - 1) = vbWhite
        Next i
        
        .Redraw = True
    End With
    
   '刷新控制数组
    'iFixedCols = rs.RecordCount + iBeginCol + 1
    iFixedCols = maxrows + WglrGrid.FixedCols
    '网格隐藏(非操作显示)列数
     GridInf(1) = iBeginCol                         '起始列值
     With Me.WglrGrid
        ReDim GridBoolean(.Cols - 1, 1 To 6)
        ReDim GridInt(.Cols - 1, 1 To 7)
        ReDim GridStr(.Cols - 1, 1 To 5)
        
    
        For i = 0 To iFixedCols - 1
            GridBoolean(i, 1) = False                           '网格列是否可编辑
            GridBoolean(i, 2) = False                           '网格列是否提供帮助，'如果提供帮组只需调整本行为真
            GridBoolean(i, 3) = False                           '网格列是否列表框录入
            GridBoolean(i, 4) = False                           '网格列是否合计
            GridBoolean(i, 5) = True                            '网格内容为零是否清空
            GridBoolean(i, 6) = False                           '网格列是否为布尔型
            
            GridInt(i, 1) = 6                                   '字段数据类型
            GridInt(i, 2) = 10                                  '字段录入长度
            GridInt(i, 3) = 6                                   '字段整数位长度
            GridInt(i, 4) = 4                                   '字段小数位长度
            GridInt(i, 5) = 0                                   '字段不允许为空或为零
            GridInt(i, 6) = 0                                   '帮助类型
            GridInt(i, 7) = 1                                   '帮助返回值(0-显示返回编码 1-显示返回名称)
    
            GridStr(i, 1) = IIf(i - iBeginCol + 1 > 0, Format(i - iBeginCol + 1, "000"), Format(0, "000"))   '网格列索引值
            GridStr(i, 2) = ""                                  '字段为空提示信息
            GridStr(i, 3) = ""                                  '通用帮助编码
            GridStr(i, 4) = ""                                  '连接字段(通用帮助)
            GridStr(i, 5) = ""                                  '列表框编码
            
            '设置考核指标列上下居中
            If i <= 3 Then
                WglrGrid.ColAlignment(i) = flexAlignCenterCenter
            Else
                WglrGrid.ColAlignment(i) = flexAlignLeftCenter
            End If
            
        Next i
    End With
    
    
    Set rs = Nothing
    Set cn = Nothing
        
    
End Function

Private Sub Sub_QuerySub()                         '生成查询结果,填充评价标准

    Dim Sqlstr As String                           '临时使用字符串
    Dim RecTemp As New ADODB.Recordset             '临时使用动态集
    Dim Jsqte, jsqteh, jsqtel As Long              '临时计数器
    Dim str_Temp As String                         '临时使用字符串

    If NullFlag = False Then Exit Sub
    
    '禁止网格刷新动作,为加快网格显示速度(Fixed)
    WglrGrid.Redraw = False
    
    ReDim Preserve strFactor(UBound(strFactor, 1), 5)
        
        '填充评价标准及分值
        For jsqteh = WglrGrid.FixedRows To WglrGrid.Rows - 1
            jsqtel = WglrGrid.FixedCols
            str_value = ""
            If RecTemp.State = 1 Then RecTemp.Close
            
            If strFactor(jsqteh, 1) = "0" Then
                Sqlstr = " SELECT PointMin,PointMax FROM Kh_Point  " & _
                         " where  PointCode ='" & strFactor(jsqteh, 2) & "'"
                         
                Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
                If RecTemp.RecordCount <> 0 Then
                    strFactor(jsqteh, 5) = RecTemp.Fields("PointMax")
                    Do While Not RecTemp.EOF()
                        str_value = "最大值" & Chr(13) & "(" & Trim(RecTemp.Fields("PointMax") & "") & "分)"
                        WglrGrid.TextMatrix(jsqteh, jsqtel) = str_value
                    
                        str_value = "最小值" & Chr(13) & "(" & Trim(RecTemp.Fields("PointMin") & "") & "分)"
                        WglrGrid.TextMatrix(jsqteh, jsqtel + 1) = str_value
                        
                        RecTemp.MoveNext
                        jsqtel = jsqtel + 1
                    Loop
                End If
            Else
                         
                Sqlstr = " SELECT Standard,GauListMark " & _
                         " FROM Kh_v_Standard where FactorCode='" & strFactor(jsqteh, 5) & "'" & _
                         " Order By  FactorCode, GauListCode"
             
                         
                Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
                If RecTemp.RecordCount <> 0 Then
                    strFactor(jsqteh, 5) = RecTemp.Fields("GauListMark")
                    Do While Not RecTemp.EOF()
                
                       '为了字符串分行显示
                        If Not IsNull(RecTemp.Fields("Standard")) Then
                            str_Temp = Trim(RecTemp.Fields("Standard"))
                        Else
                            str_Temp = ""
                        End If
                        str_value = ""
'                        Do
'                            str_value = str_value & Mid(str_Temp, 1, 4) + Chr(13)
'                            str_Temp = Mid(str_Temp, 5)
'
'                        Loop While Len(str_Temp) > 0
                        
                        str_value = str_Temp
                                
                        str_value = str_value & "(" & Trim(RecTemp.Fields("GauListMark") & "") & "分)"
                    
                        WglrGrid.TextMatrix(jsqteh, jsqtel) = str_value            '评价标准
                        RecTemp.MoveNext
                        jsqtel = jsqtel + 1
                    Loop
                End If
            End If
            
        Next jsqteh
        
        '以下为添加合计行,考核指标权重*考核要素权重*考核要素对应最大分值
        Dim Sng_total As Single
            Sng_total = 0
        For Jsqte = WglrGrid.FixedRows To WglrGrid.Rows - 1
            Sng_total = Sng_total + Val(strFactor(Jsqte, 3)) * Val(strFactor(Jsqte, 4)) * Val(strFactor(Jsqte, 5))
        Next Jsqte
        WglrGrid.AddItem ""
        WglrGrid.TextMatrix(Jsqte, Sydz("002", GridStr(), Szzls)) = "合  计"
        WglrGrid.TextMatrix(Jsqte, Sydz("003", GridStr(), Szzls)) = Format(Sng_total, "#######.000")
        WglrGrid.RowHeight(Jsqte) = 270
                
    '将网格刷新解禁(Fixed)
    WglrGrid.Redraw = True
       
End Sub

'===================以 下 程 序 为 通 用 部 分 ,一 般 不 需 更 改(程序动作部分)======================='

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)   '表格格式设置(通用)
    
    Select Case Button.Key
        Case "bcgs"                                       '保存表格格式
            Call Bcwggs(WglrGrid, GridCode, GridStr())
        Case "hfmrgs"                                     '恢复默认格式
            Call Hfmrgs(WglrGrid, GridCode, GridStr())
    End Select

End Sub

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
    
    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 2                                          '报 表 小 标 题 行 数
    Bbbwhgs = 2                                          '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    Bbzbt = ReportTitle
    
    '<<以下为自加
    
    Bbxbt(1) = "考核类别:" + GetComboKey(Imgcbo_Title, 1)
    bbxbtzzxs(1) = 0                                    '居左
    Bbxbt(2) = "姓名:          部门:           岗位:        "
    bbxbtzzxs(2) = 0                                    '居左
    
      
    Dim Reportfooter As String
    Dim str_Sqltemp As String
    Dim rst_temp As New ADODB.Recordset
            
    str_Sqltemp = "SELECT Kh_ValList.ValListCode,Kh_ValList.ValListName " & _
                    " FROM Kh_ValList INNER JOIN " & _
                           " Kh_Title ON Kh_ValList.CheckCode = Kh_Title.CheckCode " & _
                    " where  Kh_Title.TitleCode='" & Trim(str_TitleCode) & "'"
    Set rst_temp = Cw_DataEnvi.DataConnect.Execute(str_Sqltemp)
    If rst_temp.RecordCount <> 0 Then
        Reportfooter = ""
        Do While Not rst_temp.EOF
            Reportfooter = Reportfooter & "○" & Trim(rst_temp!ValListName) & Space(3)
            rst_temp.MoveNext
        Loop
    End If
    rst_temp.Close
    Set rst_temp = Nothing
  
    Bbbwh(1) = "考核者所在位置:"
    Bbbwh(2) = Reportfooter
    
  '>>以上为自加
  
    Call Scyxsjb(WglrGrid)                               '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If

End Sub