standardreport.bas

金算盘软件代码

Attribute VB_Name = "StandardReport"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  交叉表向导,标准表向导,列表向导模块
'  作者：邓强
'  日期：1998.05.26
'
'  CmdEnabled                           判断传送按纽的可用性
'  SendField                            列表间传送字段
'  FieldUpdown                          列表字段的上下移动
'
'  ReportFunc                           报表表头表尾涵数处理
'  ConvertFieldType                     转换字段类型(由英文变成中文)
'  DealCustom                           处理自定义项目报表字段名
'  CallFreeCellMenu                     装载自由单元弹出菜单
'  CallReportPopMenu                    装载报表窗体弹出菜单

'  GetBasePeriods                       得到帐套会计期间数
'  GetParaSql                           得到参数查询

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Public Enum ParaQueryType      '参数查询类型枚举
    pqtRLastSale = 1           '上次销售ID
    pqtRQReceive               '到货数量
    pqtRQSend                  '发货数量
    pqtRSaleQ                  '销售数量
    pqtRStockQ                 '库存数量
    
End Enum

'判断传送按纽的可用性
Public Sub CmdEnabled(LstSource As ListBox, cmdPart As CommandButton, Optional cmdall As CommandButton)
    If LstSource.SelCount = 0 Then
        cmdPart.Enabled = False
    Else
        cmdPart.Enabled = True
    End If
    If cmdall Is Nothing Then
    Else
        If LstSource.ListCount = 0 Then
            cmdall.Enabled = False
        Else
            cmdall.Enabled = True
        End If
    End If
 End Sub

'列表间传送字段
Public Sub SendField(LstSource As ListBox, LstAim As ListBox, Optional ByVal blnIsAll As Boolean = False)
Dim intCount As Integer, intLoc As Integer
Dim strTemp As String
   intCount = 0
   Do While intCount < LstAim.ListCount
      LstAim.Selected(intCount) = False
      intCount = intCount + 1
   Loop
   If blnIsAll Then
      intCount = 0
      Do While intCount < LstSource.ListCount
            strTemp = LstSource.list(intCount)
            LstSource.RemoveItem intCount
            LstAim.AddItem strTemp
            LstAim.Selected(LstAim.NewIndex) = True
      Loop
   Else
      intCount = 0
      Do While intCount < LstSource.ListCount
         If LstSource.Selected(intCount) = True Then
            strTemp = LstSource.list(intCount)
            LstSource.RemoveItem intCount
            LstAim.AddItem strTemp
            LstAim.Selected(LstAim.NewIndex) = True
            intLoc = intCount
         Else
         intCount = intCount + 1
         End If
      Loop
   End If
      If LstSource.ListCount = 0 Then Exit Sub
      If intLoc = LstSource.ListCount Then
         LstSource.Selected(intLoc - 1) = True
      Else
         LstSource.Selected(intLoc) = True
      End If
End Sub

 '列表字段的上下移动
Public Sub FieldUpdown(Lst As ListBox, ByVal intDirection As Integer)
  Dim intCount As Integer
  Dim strTemp As String
  If Lst.SelCount <> 1 Then Exit Sub
   '找到被选项
    For intCount = 0 To Lst.ListCount - 1
     If Lst.Selected(intCount) = True Then Exit For
    Next intCount
    
    strTemp = Lst.list(intCount)
    Lst.Selected(intCount) = False
    If intDirection = 0 Then       '向上
        Lst.RemoveItem intCount
        Lst.AddItem strTemp, intCount - 1
        Lst.Selected(intCount - 1) = True
    ElseIf intDirection = 1 Then   '向下
        Lst.RemoveItem intCount
        Lst.AddItem strTemp, intCount + 1
        Lst.Selected(intCount + 1) = True
    End If
 End Sub

'装载自由单元弹出菜单
Public Sub CallFreeCellMenu(Optional ByVal blnHead As Boolean = True)
    Dim intCount As Integer
    Dim strHead As String, strTail As String
    
    If blnHead Then
        strHead = "底端"
        strTail = "顶端"
    Else
        strHead = "顶端"
        strTail = "底端"
    End If
    With frmMain
        For intCount = .mnuListActivityMenu.Count - 1 To 1 Step -1
            Unload .mnuListActivityMenu(intCount)
        Next
        For intCount = 1 To 1
           Load .mnuListActivityMenu(intCount)
        Next intCount
         
        .mnuListActivityMenu(0).Caption = "修改自由表头  (&E)"
        .mnuListActivityMenu(0).Checked = False
        .mnuListActivityMenu(0).Enabled = True
        .mnuListActivityMenu(0).Visible = True
        
        .mnuListActivityMenu(1).Caption = "删除自由表头  (&D)"
        .mnuListActivityMenu(1).Checked = False
        .mnuListActivityMenu(1).Enabled = True
        .mnuListActivityMenu(1).Visible = True
                
   End With
End Sub
'装载报表窗体弹出菜单
Public Sub CallReportPopMenu(Optional EditObject As String = " ")
  Dim intCount As Integer

    With frmMain
        For intCount = .mnuListReportMenu.Count - 1 To 1 Step -1
            Unload .mnuListReportMenu(intCount)
        Next
        For intCount = 1 To 13
           Load .mnuListReportMenu(intCount)
        Next intCount
        .mnuListReportMenu(0).Caption = "报表设置" & EditObject & "(&Z)"
        .mnuListReportMenu(0).Checked = False
        .mnuListReportMenu(0).Enabled = True
        .mnuListReportMenu(0).Visible = True
        
        .mnuListReportMenu(1).Caption = "格式设置" & EditObject & "(&O)"
        .mnuListReportMenu(1).Checked = False
        .mnuListReportMenu(1).Enabled = True
        .mnuListReportMenu(1).Visible = True
        
        .mnuListReportMenu(2).Checked = False
        .mnuListReportMenu(2).Enabled = True
        .mnuListReportMenu(2).Caption = "-"
        .mnuListReportMenu(2).Visible = True
        
        .mnuListReportMenu(3).Caption = "报表保存" & EditObject & "(&M)"
        .mnuListReportMenu(3).Checked = False
        .mnuListReportMenu(3).Enabled = True
        .mnuListReportMenu(3).Visible = True
        
        .mnuListReportMenu(4).Caption = "报表另存" & EditObject & "(&V)"
        .mnuListReportMenu(4).Checked = False
        .mnuListReportMenu(4).Enabled = True
        .mnuListReportMenu(4).Visible = True
        
        .mnuListReportMenu(5).Checked = False
        .mnuListReportMenu(5).Enabled = True
        .mnuListReportMenu(5).Caption = "-"
        .mnuListReportMenu(5).Visible = True
        
        .mnuListReportMenu(6).Caption = "打印" & Space(4) & EditObject & "(&P)"
        .mnuListReportMenu(6).Checked = False
        .mnuListReportMenu(6).Enabled = True
        .mnuListReportMenu(6).Visible = True
        
        .mnuListReportMenu(7).Checked = False
        .mnuListReportMenu(7).Enabled = True
        .mnuListReportMenu(7).Caption = "-"
        .mnuListReportMenu(7).Visible = True
        
        .mnuListReportMenu(8).Caption = "锁定表头表尾" & EditObject & "(&L)"
        .mnuListReportMenu(8).Checked = False
        .mnuListReportMenu(8).Enabled = True
        .mnuListReportMenu(8).Visible = True
               
        .mnuListReportMenu(9).Caption = "显示对齐网格" & EditObject & "(&G)"
        .mnuListReportMenu(9).Checked = False
        .mnuListReportMenu(9).Enabled = False
        .mnuListReportMenu(9).Visible = True
        
        .mnuListReportMenu(10).Caption = "表头自动对齐" & EditObject & "(&B)"
        .mnuListReportMenu(10).Checked = False
        .mnuListReportMenu(10).Enabled = False
        .mnuListReportMenu(10).Visible = True
                
        .mnuListReportMenu(11).Caption = "数据列同宽度" & EditObject & "(&S)"
        .mnuListReportMenu(11).Checked = True
        .mnuListReportMenu(11).Enabled = True
        .mnuListReportMenu(11).Visible = False
        
        .mnuListReportMenu(12).Checked = False
        .mnuListReportMenu(12).Enabled = True
        .mnuListReportMenu(12).Caption = "-"
        .mnuListReportMenu(12).Visible = True
        
        
        .mnuListReportMenu(13).Caption = "自动刷新" & EditObject & "(&R)"
        .mnuListReportMenu(13).Checked = True
        .mnuListReportMenu(13).Enabled = True
        .mnuListReportMenu(13).Visible = True
         
   End With
End Sub

'是否为数据类型字段
Public Function IsNumType(ByVal strName As String, Optional ByVal blnDate As Boolean = False, Optional ByVal blnDouble As Boolean = False) As Boolean
    Select Case UCase(strName)
    Case "DOUBLE"
        IsNumType = True
    Case "BYTE", "INTEGER", "SINGLE", "DECIMAL", "LONG", "CURRENCY "
        If blnDouble Then
            IsNumType = False
        Else
            IsNumType = True
        End If
    Case "PERIOD", "DATE"
        If blnDate Then
            IsNumType = True
        Else
            IsNumType = False
        End If
    Case Else
        IsNumType = False
    End Select
End Function
'截去分隔符分隔的字符串尾巴
Public Function DelStringTail(Optional ByVal strSource As String = "", Optional strSeprater As String = "-") As String
 Dim strTemp As String
 Dim intCount As Integer, intLen As Integer, intStr As Integer
   strTemp = strSource
   intLen = Len(Trim(strTemp))
   intStr = Len(Trim(strSeprater))
   If strTemp = "" Or intLen <= intStr Then
        DelStringTail = ""
        Exit Function
   End If
   For intCount = intStr - 1 To intLen - 1
       If Mid(strTemp, intLen - intCount, intStr) = strSeprater Then Exit For
   Next intCount
   If intCount >= intLen - 1 Then
        DelStringTail = ""
   Else
        DelStringTail = Left(strTemp, intLen - intCount - 1)
   End If
End Function
'是否为级次编码
Public Function IsLevelCode(ByVal strName As String) As Boolean
    Select Case Right(strName, 2)
    Case "编码", "编号"
        Select Case Left(strName, Len(strName) - 2)
        Case "科目", "部门", "货位", "固资类别", "固资类型", "单位类型", "单位类别", "商品类型", "商品类别", "职员类别", "统计", "项目", "地区", "商品产地", "在建工程"
            IsLevelCode = True
        Case Else
            IsLevelCode = False
        End Select
    Case Else
        IsLevelCode = False
    End Select
End Function

'取出用分隔符分隔的字符串中前X个子串（第intSect段）
Public Function GetPreXStr(Optional ByVal strSource As String = "", Optional ByVal intSect As Integer = 1, Optional strSeprater As String = " ") As String
 Dim strTemp As String