frmruning.frm

这是一个实际的工程中所用的源程序

         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   900
         Style           =   1  'Graphical
         TabIndex        =   2
         Top             =   0
         Width           =   900
      End
      Begin VB.CommandButton cmd明细 
         BackColor       =   &H00FFC0FF&
         Caption         =   "查   询"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   0
         Style           =   1  'Graphical
         TabIndex        =   1
         Top             =   0
         Width           =   900
      End
   End
   Begin VB.Menu mnuData 
      Caption         =   "【选    项】"
      Visible         =   0   'False
      Begin VB.Menu mnuCopy 
         Caption         =   "【备份数据】"
      End
   End
   Begin VB.Menu mnuHome 
      Caption         =   "【返回主界面】"
      Visible         =   0   'False
   End
End
Attribute VB_Name = "frmRuning"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim iRecordCount As Long '查询结果的记录数
Dim iQueryType As Integer '查询按日(0)/班(1)
'
'
Private Type TTitle
    标题  As String '3
    日期  As String '9.
    班次  As String '2.
End Type
Dim rptTitle As TTitle        '2.报表主标题


Private Sub getTitle() '输出  rptTitle
If dtpDate(0).Value = dtpDate(1).Value Then '日查询
    rptTitle.日期 = FormatDateTime(dtpDate(0).Value, vbLongDate)
Else '日期区间
     rptTitle.日期 = FormatDateTime(dtpDate(0).Value, vbLongDate) & " -- " & FormatDateTime(dtpDate(1).Value, vbLongDate)
End If
    rptTitle.班次 = cobWeight(1).Text

End Sub

'*********************** cmd查询,cmd打印 **************************************************************
'
Private Sub cmdClose_Click()
Unload Me
End Sub

'
'
Private Sub dtpDate_Validate(Index As Integer, Cancel As Boolean)
    Dim msg As String
    Dim bErr As Boolean
    If Index = 0 Then
        If dtpDate(0).Year < 2003 Or dtpDate(0).Year > Year(Date) Then
            msg = "没有此年的数据！"
            bErr = True
        Else
            If Dir(PATH_Year(Date)) = "" Then
                msg = "没有此年的数据！"
               bErr = True
            End If
         End If
    End If
    If Index = 1 Then
'        If dtpDate(1).Month <> dtpDate(0).Month Then
'            msg = "不能跨月度查询."
'            bErr = True
'        End If
        If dtpDate(0).Value > dtpDate(1).Value Then
           msg = "错：起点日期大于终点日期！"
            bErr = True
        End If
    End If
    If bErr Then
        If MsgBox(msg, vbExclamation + vbRetryCancel, "日期区间选择错误") = vbRetry Then
             Cancel = True
         Else
             Cancel = False
         End If
    Else
    End If
End Sub
'

Private Sub Form_Resize()
    On Error Resume Next
    If Me.ScaleWidth > txtTitle.Width Then
    MFlex.Width = Me.ScaleWidth
    txtTitle.Left = (Me.ScaleWidth - txtTitle.Width) / 2
    End If
    If Me.ScaleHeight > 1500 Then
    Frame2.Top = Me.ScaleHeight - Frame2.Height - 30
    MFlex.Top = 0 'txtTitle.Height + 60
    MFlex.Height = Frame2.Top - MFlex.Top - 30
    End If
    Picture1.Top = Frame2.Top + 60

End Sub

'
Private Function CN_Year(ByVal DDate) As String  '数据环境连接
    Dim strCN As String
    strCN = CN_Str40 & PATH_Year(DDate)
     CN_Year = strCN
End Function
Private Function CN_Shape(ByVal DDate As Date) As String  '数据形状连接
    Dim strCN As String
    strCN = Shape_Str40 & PATH_Year(DDate)
    CN_Shape = strCN
End Function
Private Function PATH_Year(ByVal DDate) As String
    PATH_Year = PATH_mdb & "JLD" & Format$(DDate, "YYYY") & ".mdb"
End Function
'
'
'
Private Sub Form_Load()
    Dim i As Integer
    On Error GoTo err1
    
    txtTitle.Text = App_CompanyName
    dtpDate(0).Value = Date
    dtpDate(1).Value = Date
    lblWhere(0).Caption = nmShop(eShop.e船名)
    With cobWeight(0)
        .ToolTipText = nmShop(eShop.e船名)
        .Clear
'        For i = 0 To BRY.班次数 - 1
'            .AddItem BRY.班次(i)
'        Next i
    End With
    lblWhere(1).Caption = nmShop(eShop.e煤种)
    With cobWeight(1)
        .ToolTipText = nmShop(eShop.e煤种)
        .Clear
'        For i = 0 To BRY.班次数 - 1
'            .AddItem BRY.班次(i)
'        Next i
    End With
    lblWhere(2).Caption = nmShop(eShop.e仪表)
    With cobWeight(2)
        .ToolTipText = nmShop(eShop.e仪表)
        .Clear
        For i = 1 To TechCount
            .AddItem NameTech(i)
        Next i
    End With
    Call toQuery(0)
    Exit Sub
err1:
    Err.Clear
    Resume Next
End Sub
Private Sub cmd打印_Click()
    Call toPrint(iQueryType)
End Sub

Private Sub cmd明细_Click()
Call toQuery(iQueryType)
End Sub
Private Sub toQuery(ByVal vType As Integer)
        
    Dim cmdText As String
    On Error GoTo err1
    cmdText = getSQL(vType, True) & getWHERE(vType) & getORDER(vType)
    'Debug.Print cmdText
    adoShape.ConnectionString = CN_Year(dtpDate(0).Value)
    adoShape.RecordSource = cmdText
    adoShape.Refresh
    iRecordCount = adoShape.Recordset.RecordCount
    Me.Caption = "[查询和报表] ---> 记录数:" & CStr(iRecordCount) & " 条"
    If iRecordCount <= 0 Then
      MsgBox "没有查询到所要求的记录.", vbExclamation, Me.Caption
'    MFlex.FormatString = getFormatString(vType) '格式化MFlex的标题
    Else
      Set MFlex.Recordset = adoShape.Recordset
      MFlex.Refresh
      Call FormatMFlex(vType)
      Set MFlex.Recordset = Nothing
    End If
    Exit Sub
err1:
    Debug.Assert False
     Call meErr("frmQuery:getQuery", Err.Description)
     Err.Clear
     Resume Next
End Sub
Private Sub FormatMFlex(ByVal vType As Integer)
'界面预设置:行标头:True,固定行:0,固定列:0,行数:2
'    MFlex.FixedRows = 1
    Dim i As Integer
'                         nmShop (eShop.e日期) & "," & _
'                         nmShop(eShop.e时间) & "," & _
'                         nmShop(eShop.e仪表) & "," & _
'                         nmShop(eShop.e船名) & "," & _
'                         nmShop(eShop.e煤种) & "," & _
'                         nmShop(eShop.e流程) & "," & _
'                         nmShop(eShop.e设定) & "," & _
'                         nmShop(eShop.e计量) & "," & _
'                         nmShop(eShop.e备注)
            MFlex.ColWidth(0) = 1500
            MFlex.ColWidth(1) = 1500
            MFlex.ColWidth(2) = 900
            MFlex.ColWidth(3) = 2400
            MFlex.ColWidth(4) = 1200
            MFlex.ColWidth(5) = 900
            MFlex.ColWidth(6) = 1200
            MFlex.ColWidth(7) = 1200
            'MFlex.ColWidth(8) = 1800
            MFlex.ColAlignment(6) = flexAlignRightCenter
            MFlex.ColAlignment(7) = flexAlignRightCenter
End Sub

Private Sub toPrint(ByVal vType As Integer)
    
    Dim cmdText As String
    On Error GoTo err1
    cmdText = getSQL(vType, False) & getWHERE(vType) & getORDER(vType)
    
    If DE.CN_Shape.State = adStateOpen Then
        DE.CN_Shape.Close
    End If
    DE.CN_Shape.ConnectionString = CN_Year(dtpDate(0).Value)
    DE.CN_Shape.Open
    DE.Commands("ShapeDetail").CommandText = cmdText
    
    DE.ShapeDetail
    DoEvents
    iRecordCount = DE.rsShapeDetail.RecordCount
    
    If iRecordCount > 0 Then
        Call getTitle
            rptBan.Sections("ReportHead").Controls("lblDate").Caption = rptTitle.日期
            rptBan.Show vbModal
    Else
        MsgBox "没有查询到所要求的记录.", vbExclamation, Me.Caption
    End If
     Exit Sub
err1:
    Debug.Assert False
     Call meErr("frmQuery:getQuery", Err.Description)
     Err.Clear
     Resume Next
End Sub
Private Function getSQL(ByVal vType As Integer, ByVal isFormat As Boolean) As String
'getQuery调用
    '
    Dim vSQL As String
        vSQL = "SELECT " & _
                         nmShop(eShop.e日期) & "," & _
                         nmShop(eShop.e时间) & "," & _
                         nmShop(eShop.e仪表) & "," & _
                         nmShop(eShop.e船名) & "," & _
                         nmShop(eShop.e煤种) & "," & _
                         nmShop(eShop.e流程) & "," & _
                         nmShop(eShop.e设定) & ","
        If isFormat Then
        vSQL = vSQL & "FORMAT(" & nmShop(eShop.e计量) & " ," & """" & "#0.00" & """" & ") AS  [装船量]"
        Else
        vSQL = vSQL & nmShop(eShop.e计量) & " AS  [装船量]"
        End If
        
            getSQL = vSQL & " FROM tblBanXR "
            
End Function
Private Function getWHERE(ByVal vType As Integer) As String     '输出 Where
'getQuery调用
'
Dim sql         As String
Dim wDate       As String '日期

'1.查询条件

If dtpDate(0).Value = dtpDate(1).Value Then '日查询
    wDate = nmShop(eShop.e日期) & "=#" & Format$(dtpDate(0).Value, "yyyy-mm-dd") & "#"
Else '日期区间
    wDate = "(" & nmShop(eShop.e日期) & " BETWEEN #" & Format$(dtpDate(0).Value, "yyyy-mm-dd") & "# AND #" & Format$(dtpDate(1).Value, "yyyy-mm-dd") & "#)"
End If

    sql = " WHERE " + wDate ' + " AND "
        '船名
        If Trim(cobWeight(0).Text) <> "" Then '
            sql = sql & " AND " & cobWeight(0).ToolTipText & " ='" & Trim(cobWeight(0).Text) & "'"
        End If
        '煤种
        If Trim(cobWeight(1).Text) <> "" Then '
            sql = sql & " AND " & cobWeight(1).ToolTipText & " ='" & Trim(cobWeight(1).Text) & "'"
        End If
        '仪表
        If Trim(cobWeight(2).Text) <> "" Then '
            sql = sql & " AND " & cobWeight(2).ToolTipText & " ='" & Trim(cobWeight(2).Text) & "'" ' & Trim(cobWeight(2).ListIndex + 1) & "'"
        End If
getWHERE = sql
End Function
Private Function getORDER(ByVal vType As Integer) As String
'getQuery调用
    Dim s As String
    s = " ORDER BY " & nmShop(eShop.e日期) & "," & nmShop(eShop.e时间) & "," & nmShop(eShop.e仪表)
    getORDER = s
End Function