frmtable.frm

金算盘软件代码

        strSel = LstReport.list(LstReport.ListIndex)
        blnIsSame = FindSameField(txtList.Text, LstReport.ListIndex)
        If blnIsSame Then
            Utility.ShowMsg Me.hwnd, "已有名称'" & txtList.Text & "'了,请重新命名!", vbOKOnly + vbInformation, App.title
            txtList.Text = StringOut(strSel, Space(100))
        End If
    End If
    If Len(txtList.Text) > 30 Then
       Utility.ShowMsg Me.hwnd, "项目名称太长了,请重新命名!", vbOKOnly + vbInformation, App.title
       txtList.Text = Left(txtList.Text, 30)
    Else
       strTail = LstReport.list(LstReport.ListIndex)
       strSel = StringOut(strTail, Space(100))
       LstReport.list(LstReport.ListIndex) = txtList.Text & Space(100) & strTail
    End If
End Sub


Private Sub txtList_LostFocus()
  Dim strSel As String
  Dim blnErr As Boolean
    If Me.ActiveControl Is cmdCancel Then Exit Sub
    If sstTable.Tab <> 1 Then Exit Sub
    If Trim(txtList.Text) = "" Then
     strSel = LstReport.list(LstReport.ListIndex)
     txtList.Text = StringOut(strSel, Space(100))
    End If
    blnErr = NameIsErr(txtList.Text, strSel)
    If blnErr Then
        Utility.ShowMsg Me.hwnd, "列名不能有非法字符:'" & strSel & "'!", vbOKOnly + vbInformation, App.title
        sstTable.Tab = 1
        txtList.SetFocus
        Exit Sub
    End If
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'         以下为自定义过程

'设置向导按钮的可用性
Private Sub CmdISEnabled(intIndex As Integer)
    Select Case intIndex
    Case 0
      cmdPrevious.Enabled = False
      cmdnext.Enabled = True
    Case 1
      cmdnext.Enabled = True
      cmdPrevious.Enabled = True
    Case 2
      cmdnext.Enabled = False
      cmdPrevious.Enabled = True
    End Select
End Sub

'查找同名项目
Private Function FindSameField(strName As String, intIndex As Integer) As Boolean
Dim intCount As Integer
Dim strTemp As String
    
    intCount = 0
    Do While intCount < LstDataField.ListCount
        If intCount <> intIndex Then
            strTemp = LstDataField.list(intCount)
            strTemp = StringOut(strTemp, Space(100))
            If strTemp = strName Then
                FindSameField = True
                Exit Function
            End If
        End If
        intCount = intCount + 1
    Loop
    intCount = 0
    Do While intCount < LstReport.ListCount
        If intCount <> intIndex Then
            strTemp = LstReport.list(intCount)
            strTemp = StringOut(strTemp, Space(100))
            If strTemp = strName Then
                FindSameField = True
                Exit Function
            End If
        End If
        intCount = intCount + 1
    Loop
    FindSameField = False
End Function

'完成按钮是否有效
Private Sub IsComplete()
  If Trim(txtName.Text) = "" Or LstReport.ListCount = 0 Then
      cmdComplete.Enabled = False
  Else
      cmdComplete.Enabled = True
  End If
End Sub

'初始化向导
Private Sub InitTableWizard(intTab As Integer)
   Dim intCount As Integer, intColumn As Integer
   Dim strItem As String, strSql As String
   Dim strTemp As String, strRep As String
   Dim rstData As rdoResultset
   Dim strCondVersion As String
     
     If mblnIsInited(intTab) = True Then Exit Sub
     Select Case intTab
     Case 0
        txtName.Text = mclsTable.ReportName
        Me.Caption = mclsTable.ReportName
        mblnIsInited(0) = True
'     Case 1
     '初始化列表
     '对数据项目列表初始化
        LstDataField.Clear
        
     #If conVersionType = 1 Then
        strCondVersion = " And MOD(ViewField.bytVersion ,2)>0 "
     #Else
        #If conVersionType = 2 Then
          strCondVersion = " And MOD(ViewField.bytVersion ,4)>1 "
        #Else
          #If conVersionType = 4 Then
           strCondVersion = " And MOD(ViewField.bytVersion ,8)>3 "
          #Else
             #If conVersionType = 8 Then
                strCondVersion = " And MOD(ViewField.bytVersion,16)>7 "
             #Else
                strCondVersion = " And MOD(ViewField.bytVersion,32)>15  "
             #End If
          #End If
        #End If
     #End If
        
        strSql = "SELECT   ReportField.*,ViewField.* FROM   ReportField ,ViewField  " _
               & " WHERE ReportField.lngViewFieldID = ViewField.lngViewFieldID And " & _
               "   ReportField.lngReportID =" & mclsTable.ReportID & strCondVersion
        Set rstData = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        With rstData
         Do While Not .EOF
           If !strViewFieldDesc <> "年" And !strViewFieldDesc <> "月" And !strViewFieldDesc <> "日" Then
           LstDataField.AddItem !strReportFieldDesc & Space(100) & .rdoColumns("lngViewFieldID") & "\" _
                    & !strTableName & "\" & !strFieldName & "\" & !strFieldType & "\" _
                    & !bytFieldSize & "\" & !strViewFieldDesc & "\" & !lngDisplayWidth & "\" & !bytFormula
           End If
           .MoveNext
        Loop
        End With
        '对报表列表初始化(已选项目)
        LstReport.Clear
        intColumn = 0
         Do While intColumn < mclsTable.Columns
            intCount = 0
            Do While intCount < LstDataField.ListCount
            strRep = LstDataField.list(intCount)
            strItem = StringOut(strRep, Space(100))
            strItem = GetNoXString(strRep, 3, "\")
                If strItem = mclsTable.ColumnFieldName(intColumn) Then
                   LstReport.AddItem mclsTable.ColumnDesc(intColumn) & Space(100) & mclsTable.ColumnID(intColumn) & "\" _
                                     & GetNoXString(strRep, 2, "\") & "\" & GetNoXString(strRep, 3, "\") & "\" _
                                     & mclsTable.ColumnFieldType(intColumn) & "\" & GetNoXString(strRep, 5, "\") & "\" _
                                     & GetNoXString(strRep, 6, "\") & "\" & mclsTable.ColumnWidth(intColumn) & "\" & GetNoXString(strRep, 8, "\")
                   LstDataField.RemoveItem intCount
                   Exit Do
                Else
                   intCount = intCount + 1
                End If
            Loop
            intColumn = intColumn + 1
        Loop
        txtList.Enabled = False
        LblList.Enabled = False
        LstClick LstReport, cmdUpDown(0), cmdUpDown(1)
        CmdEnabled LstDataField, cmdArrow(0), cmdArrow(1)
        CmdEnabled LstReport, cmdArrow(2), cmdArrow(3)
        IsComplete
        mblnIsInited(1) = True
     Case 2
'        mclsFilter.InitCondArr mclsTable.ReportID, mclsTable.ViewId, 2
        mclsFilter.ShowFilter Me, mclsTable.ReportID, 2, 64, , "日期"
        CmdReset.Visible = True
        mblnIsInited(2) = True
     End Select
 End Sub
 
'列表下的数据浏览
Private Sub LstBrowse(Lst As ListBox)
    Dim frm As New frmBrowse
    Dim intCount As Integer
    Dim rstBrowse As rdoResultset
    Dim strSql As String
    Dim strTail As String, strHead As String
    Dim strType As String, strLen As String
    
    On Error Resume Next
    strTail = Lst.list(Lst.ListIndex)
    strHead = StringOut(strTail, Space(100))
    
    frm.LstBrowse.Clear
    If UCase(GetNoXString(strTail, 4, "\")) = "MEMO" Then
        strSql = "SELECT  " & GetNoXString(strTail, 3, "\") & " as [Name]  " _
            & mclsTable.FROM
    Else
         strSql = "SELECT DISTINCT " & GetNoXString(strTail, 3, "\") & " as [Name]  " _
            & mclsTable.FROM
    End If
    Set rstBrowse = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
'     If rstBrowse.rowcount = 0 Then
'        Utility.ShowMsg Me.hwnd, "选中项目无数据!", vbOKOnly + vbInformation, App.title
'     Exit Sub
'     End If
    rstBrowse.MoveLast
    rstBrowse.MoveFirst
    For intCount = 0 To rstBrowse.RowCount - 1
        If IsNull(rstBrowse![Name]) = False Then frm.LstBrowse.AddItem rstBrowse![Name]
        rstBrowse.MoveNext
    Next intCount
    Set rstBrowse = Nothing
    strType = GetNoXString(strTail, 4, "\")
    strLen = GetNoXString(strTail, 5, "\")
    ConvertFieldType strType
    If strLen = "0" Or strLen = "" Then strLen = "未知"
    frm.LblName.Caption = "项目名称：" & strHead
    frm.LblType.Caption = "项目类型：" & strType
    frm.LblLen.Caption = "项目长度：" & strLen
    frm.top = Me.top + 400
    frm.Left = Me.Left + 200
    frm.Show vbModal
    Set frm = Nothing
End Sub

Private Sub txtName_Change()
    If strLen(txtName.Text) > 40 Then
       Utility.ShowMsg Me.hwnd, "报表名称太长了,请重新命名!", vbOKOnly + vbInformation, App.title
       txtName.Text = strLeft(txtName.Text, 40)
       Exit Sub
    ElseIf Trim(txtName.Text) = "" Then
       Utility.ShowMsg Me.hwnd, "报表名称不能为空!", vbOKOnly + vbInformation, App.title
       cmdComplete.Enabled = False
       Exit Sub
    End If
    IsComplete
    mclsTable.TitleWidth = 0
End Sub



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'       以下是与类相关的过程与函数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub loadResPic()
    cmdUpDown(0).Picture = Utility.GetFormResPicture(1019, vbResBitmap)
    cmdUpDown(1).Picture = Utility.GetFormResPicture(1020, vbResBitmap)
    cmdCancel.Picture = Utility.GetFormResPicture(1002, vbResBitmap)
    cmdPrevious.Picture = Utility.GetFormResPicture(1005, vbResBitmap)
    cmdnext.Picture = Utility.GetFormResPicture(1006, vbResBitmap)
    cmdComplete.Picture = Utility.GetFormResPicture(1016, vbResBitmap)
    CmdReset.Picture = Utility.GetFormResPicture(1021, vbResBitmap)
    picWizard.Picture = Utility.GetFormResPicture(140, vbResBitmap)
End Sub
Private Sub UnloadResPic()
    Utility.RemoveFormResPicture 1019
    Utility.RemoveFormResPicture 1020
    Utility.RemoveFormResPicture 1002
    Utility.RemoveFormResPicture 1005
    Utility.RemoveFormResPicture 1006
    Utility.RemoveFormResPicture 1016
    Utility.RemoveFormResPicture 1021
    Utility.RemoveFormResPicture 140
    cmdUpDown(0).Picture = Nothing
    cmdUpDown(1).Picture = Nothing
    cmdCancel.Picture = Nothing
    cmdPrevious.Picture = Nothing
    cmdnext.Picture = Nothing
    cmdComplete.Picture = Nothing
    picWizard.Picture = Nothing
End Sub
'初始化向导
Public Function SetTable(clsTableSet As TableSet, clsFormCond As FormCond) As Boolean
Dim intCount As Integer
   mblnMeOK = False
   loadResPic
   Set mclsTable = clsTableSet
   Set mclsFilter = clsFormCond
   
   For intCount = 0 To 2
      mblnIsInited(intCount) = False
   Next intCount
   '设置条件钩子
   Set mclsHook = New Hook
   mclsHook.SetHook MsgFilter.hwnd
   sstTable.Tab = 0
   sstTable_Click 0                        '初始化向导
   Me.Show vbModal
   SetTable = mblnMeOK
End Function
'把各种改变的条件写进类里
Private Sub GetTableWizard()
Dim intCount As Integer
Dim strHead As String
Dim strTail As String
    With mclsTable
      .ReportName = txtName.Text
      .Columns = LstReport.ListCount
       For intCount = 0 To LstReport.ListCount - 1
         strTail = LstReport.list(intCount)
         strHead = StringOut(strTail, Space(100))
         .ColumnDesc(intCount) = strHead
         .ColumnID(intCount) = GetNoXString(strTail, 1, "\")
         .ColumnWidth(intCount) = GetNoXString(strTail, 7, "\")
         .ColumnFieldName(intCount) = GetNoXString(strTail, 3, "\")
         .ColumnFieldType(intCount) = GetNoXString(strTail, 4, "\")
       Next
    End With
End Sub
'列表选中项目，对上下按钮的影响
Private Sub LstClick(Lst As ListBox, _
        cmdUp As CommandButton, cmdDown As CommandButton)
    Dim intCount As Integer
    If Lst.SelCount = 1 And Lst.ListCount > 1 Then
        For intCount = 0 To Lst.ListCount - 1
         If Lst.Selected(intCount) = True Then Exit For
        Next intCount
        cmdUp.Enabled = IIf(intCount = 0, False, True)
        cmdDown.Enabled = IIf(intCount = Lst.ListCount - 1, False, True)
    Else
        cmdUp.Enabled = False
        cmdDown.Enabled = False
    End If
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'筛选条件设置
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'响应钩子消息
Private Sub mclsHook_OnMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCancel As Long)
  If Msg = WM_KEYUP Then
      If wParam = vbKeyUp Or wParam = vbKeyDown Then
          mclsFilter.MsgFilter_click Me
      End If
  End If
End Sub

'以下对应为条件控件过程

Private Sub CmdReset_Click()
      mclsFilter.CmdReset_Click Me
End Sub

Private Sub dateone_lostfocus()
    If sstTable.Tab <> 2 Then Exit Sub
     mclsFilter.dateone_lostfocus Me
End Sub

Private Sub ReferText1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
     mclsFilter.ReferText1_MouseDown Me, Button, Shift, x, y
End Sub

Private Sub ReferText2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    mclsFilter.ReferText2_MouseDown Me, Button, Shift, x, y
End Sub
Private Sub ReferText2_ItemNotExist()
    mclsFilter.blnNotExist = True
End Sub
Private Sub tvwFilter_Expand(ByVal Node As ComctlLib.Node)
    mclsFilter.tvwFilter_Expand Me, Node
End Sub

Private Sub tvwFilter_nodeClick(ByVal Node As ComctlLib.Node)
    mclsFilter.tvwFilter_nodeClick Me, Node
End Sub

Private Sub MsgFilter_click()
    mclsFilter.MsgFilter_click Me
End Sub

Private Sub refertext1_Choose()
    mclsFilter.refertext1_Choose Me
End Sub
Private Sub TxtFrom_KeyDown(KeyCode As Integer, Shift As Integer)
    If sstTable.Tab <> 2 Then Exit Sub
    mclsFilter.TxtFrom_KeyDown Me, KeyCode, Shift
End Sub

Private Sub txtfrom_LostFocus()
    If sstTable.Tab <> 2 Then Exit Sub
    mclsFilter.txtfrom_LostFocus Me
End Sub
         

Private Sub refertext2_Choose()
    mclsFilter.refertext2_Choose Me
End Sub

Private Sub dateto_lostfocus()
    If sstTable.Tab <> 2 Then Exit Sub
    mclsFilter.dateto_lostfocus Me
End Sub

Private Sub datefrom_lostfocus()
    If sstTable.Tab <> 2 Then Exit Sub
   mclsFilter.datefrom_lostfocus Me
End Sub

Private Sub TxtTo_KeyDown(KeyCode As Integer, Shift As Integer)
    mclsFilter.TxtTo_KeyDown Me, KeyCode, Shift
End Sub

Private Sub TxtTo_lostfocus()
    If sstTable.Tab <> 2 Then Exit Sub
   mclsFilter.TxtTo_lostfocus Me
End Sub