frmdataconn.frm

VB做的报表设计源程序,非常不错,可以自定义模版

End Sub

Private Sub cboTables_Click(Index As Integer)
'fired when user clicks on the database tables combo box to select one from the list
Dim strImageTableName As String

    If cboTables(Index).ListIndex = -1 Then Exit Sub
    
    If Index = 0 Then               'this is the connection table combo box
        strTableName = Right(cboTables(Index), Len(cboTables(Index)) - 9)
        OpenData strTableName
        LoadSortFieldCombos
        chkHasPics.Enabled = True
        cmdViewData.Enabled = True
        frmDesign.Toolbar1.Buttons(17).Enabled = True
        lblSortField.Enabled = True
        lblHeader.Enabled = True
        lblFooter.Enabled = True
        lbl1st.Enabled = True
        lbl2nd.Enabled = True
        lbl3rd.Enabled = True
    ElseIf Index = 1 Then                   'this is the image path table combo box
        strImageTableName = cboTables(Index)
        Set rstImage = New ADODB.Recordset
        rstImage.Open "Select * from [" & strImageTableName & "]" & GetSort, dbConn, adOpenStatic, adLockOptimistic, adCmdText
        rstImage.MoveLast
        rstImage.MoveFirst
        Me.cboFields(3).Clear
        For i = 0 To rstImage.Fields.count - 1
            cboFields(3).AddItem rstImage.Fields(i).Name
        Next i
        cboFields(3).Enabled = True
    End If

End Sub

Private Sub chkGrpFVis_Click(Index As Integer)

    If chkGrpFVis(Index).value = 0 Then
        If SectionHasControls(10 - Index) Then
            MsgBox "This section has existing controls!" & Chr$(13) & _
            "Please delete all controls first before hiding this section", vbCritical
            chkGrpFVis(Index).value = 1
            Exit Sub
        End If
    End If
    
    GroupFVis(Index) = -(chkGrpFVis(Index).value)

End Sub

Private Sub chkGrpHVis_Click(Index As Integer)

    If chkGrpHVis(Index).value = 0 Then
        If SectionHasControls(Index + 2) Then
            MsgBox "This section has existing controls!" & Chr$(13) & _
            "Please delete all controls first before hiding this section", vbCritical
            chkGrpHVis(Index).value = 1
            Exit Sub
        End If
    End If
    
    GroupHVis(Index) = -(chkGrpHVis(Index).value)

End Sub

Private Function SectionHasControls(SecNo As Integer) As Boolean
Dim a As Integer
    
    For a = 0 To frmDesign.Controls.count - 1
        Set ctlTest = frmDesign.Controls(a)
        If ctlTest.Tag = SecNo Then
            SectionHasControls = True
            Exit For
        End If
    Next a
        
End Function

Private Sub chkHasPics_Click()
'fired when the user clicks on the check box to select/deselect if there are images associated with records
Dim blnOnOff As Boolean

    blnOnOff = -chkHasPics.value

    Me.txtPicFolder.Enabled = blnOnOff
    Me.cboTables(1).Enabled = blnOnOff
    Me.cboFields(3).Enabled = blnOnOff
    Me.cmdFindPicFolder.Enabled = blnOnOff
    Me.cboFolderPath.Enabled = blnOnOff
    
    Me.lblImagePathHead.Enabled = blnOnOff
    Me.lblImgTable.Enabled = blnOnOff
    Me.lblImgField.Enabled = blnOnOff
    Me.lblSelPath.Enabled = blnOnOff
    Me.lblImgPath.Enabled = blnOnOff
    Me.lblOR.Enabled = blnOnOff
    Me.txtPicFolder.Enabled = blnOnOff
    Me.cmdFindPicFolder.Enabled = blnOnOff
    
    Me.cboTables(1) = ""
    Me.cboFields(3) = ""
    If txtPicFolder.Enabled Then    'user has selected the check box
        Me.cboTables(1).BackColor = vbWhite
        Me.cboFields(3).BackColor = vbWhite
    Else                                        'user has deselected the check box
        Me.cboTables(1).BackColor = &H8000000F
        Me.cboFields(3).BackColor = &H8000000F
        strPhotoFolder = ""
    End If
    
    blnHasPics = blnOnOff

End Sub

Private Sub cmdBrowse_Click()
'fired on button click - displays the open file dialog box using the onboard CommonDialog control
'and sets variables to the selected file name
On Error GoTo NoFile

    CommonDialog1.ShowOpen
    txtDataFile.text = CommonDialog1.FileName
    strDataFileName = CommonDialog1.FileName
    Me.lblConnStatus.Caption = ""
    Me.cmdConnect.Enabled = True
    Exit Sub

NoFile:

End Sub

Private Sub cmdCancel_Click()
'fired on button click - exits the form and resets data connection to the way it was
    If strOldDataFileName > "" Then
        strDataFileName = strOldDataFileName
        ConnectToDataFile
        If strOldTableName > "" Then
            If GetTables Then
                strTableName = strOldTableName
                OpenData strTableName
                LoadFieldNames
            End If
        End If
    End If
    blnPageChanged = False
    Set rstTables = Nothing
    Set rstImage = Nothing
    Me.Hide

End Sub

Private Sub cmdConnect_Click()
'fired on button click - calls ConnectToDataFile to set up ADO data connection - currently rigged for MS Access
'but I think it could be easily modified
    
    Me.lblConnStatus.Caption = "Connecting to database..."
    DoEvents
    
    If ConnectToDataFile Then
        blnConnected = True
        Me.lblConnStatus.Caption = "Connection successful."
    Else
        Me.lblConnStatus.Caption = "Error : " & strConnErrMsg
        Exit Sub
    End If
    
    If GetTables Then           'if we were successful getting table names from the database then
        LoadTableCombos
    Else
        lblConnStatus.Caption = "Error : " & strConnErrMsg
    End If

End Sub

Private Sub LoadTableCombos()

    cboTables(0).Clear      'populate the appropriate combo boxes with them
    cboTables(1).Clear
    While Not rstTables.EOF     'this is the recordset opened in call to GetTables
        If rstTables!TABLE_TYPE <> "ACCESS TABLE" And rstTables!TABLE_TYPE <> "SYSTEM TABLE" And rstTables!TABLE_TYPE <> "LINK" Then
            If rstTables!TABLE_TYPE = "TABLE" Then
                Me.cboTables(0).AddItem "(Table)  " & rstTables!TABLE_NAME
                Me.cboTables(1).AddItem rstTables!TABLE_NAME
            ElseIf rstTables!TABLE_TYPE = "VIEW" Then
                Me.cboTables(0).AddItem "(Query)  " & rstTables!TABLE_NAME
            End If
        End If
        rstTables.MoveNext
    Wend
    rstTables.Close
    cboTables(0).BackColor = vbWhite
    cboTables(0).Enabled = True

End Sub

Private Sub cmdFindPicFolder_Click()

'calls Windows API function to browse for a folder
'returns result to the textbox if successful
    Dim InDir As String
        
    InDir = BrowseFolder(Me.hwnd, "Select folder containing images")
    If InDir = "" Then
        Exit Sub
    End If
    
    strImageFolder = InDir
    Me.txtPicFolder = InDir

End Sub

Private Sub cmdOK_Click()

 Dim i As Integer

'build sort portion of SQL statement
    strSort = ""
    For i = 0 To 2
        If cboFields(i).text > "" Then
            strSortField(i) = cboFields(i).text
            blnSortDescending(i) = Me.OptDesc(i).value
            If strSort > "" Then strSort = strSort & ", "
            strSort = strSort & cboFields(i).text
            If OptDesc(i) = True Then strSort = strSort & " DESC"
        End If
    Next i
    If strSort <> "" Then strSort = "ORDER BY " & strSort

'if table or query selected then call sub to open it and load the field names
'into the frmSelField listbox
    If strTableName > "" Then
        strDataFileName = txtDataFile.text
        OpenData strTableName, strSort
        LoadFieldNames
        blnReportDataBound = True
        frmDesign.StatusBar1.Panels(2).text = "Data Source = " & _
        cboTables(0).List(cboTables(0).ListIndex) & " - from " & Right(strDataFileName, Len(strDataFileName) - InStrRev(strDataFileName, "\"))
        For i = 2 To 4
            frmDesign.cmdDivider(i).Visible = GroupHVis(i - 2)
            frmDesign.cmdDivider(i).Caption = "'" & cboFields(i - 2) & "' Group Header"
            frmDesign.picSection(i).Visible = GroupHVis(i - 2)
            frmDesign.cmdDivider(10 - i).Visible = GroupFVis(i - 2)
            frmDesign.cmdDivider(10 - i).Caption = "'" & cboFields(i - 2) & "' Group Footer"
            frmDesign.picSection(10 - i).Visible = GroupFVis(i - 2)
        Next i
        blnPageChanged = True
        Me.Hide
    Else
        If MsgBox("You have not selected a table or query as a data source for your report" & Chr$(13) _
        & "Do you wish to abort the data connection?", vbYesNo + vbQuestion) = vbYes Then
            If blnConnected Then
                dbConn.Close
                Set dbConn = Nothing
            End If
            strDataFileName = ""
            Unload Me
            Set frmDataConn = Nothing
        End If
    End If
    
    blnReportSaved = False

End Sub

Private Sub cmdViewData_Click()

    blnViewingData = True
    frmViewData.Show vbModal

End Sub

Private Sub Form_Activate()
Dim i As Integer

'sets up listboxes and textboxes if there is already a data connection established
'checks to see if there is already a data connection established

    If blnViewingData Then
        blnViewingData = False
        Exit Sub
    End If

    If strDataFileName > "" Then strOldDataFileName = strDataFileName
    If strTableName > "" Then strOldTableName = strTableName

    If blnReportDataBound Then
        cmdConnect.Enabled = True
        If strDataFileName > "" Then
            txtDataFile.text = strDataFileName
            If GetTables And cboTables(0).ListCount = 0 Then
                LoadTableCombos
            End If
            If strTableName > "" Then
                cboTables(0) = strTableName
                cboTables(0).text = strTableName
                cboTables(0).Enabled = True
                cboTables(0).BackColor = vbWhite
                Me.chkHasPics.Enabled = True
                LoadSortFieldCombos
                For i = 0 To 2
                    cboFields(i) = strSortField(i)
                    If cboFields(i) > "" Then FraOrder(i).Enabled = True
                    chkGrpHVis(i).value = -(GroupHVis(i))
                    chkGrpHVis(i).Enabled = GroupHVis(i)
                    chkGrpFVis(i).value = -(GroupFVis(i))
                    chkGrpFVis(i).Enabled = GroupFVis(i)
                Next i
                cmdViewData.Enabled = True
                lblSortField.Enabled = True
                lblHeader.Enabled = True
                lblFooter.Enabled = True
                lbl1st.Enabled = True
                lbl2nd.Enabled = True
                lbl3rd.Enabled = True
                Me.chkHasPics.value = -blnHasPics
                chkHasPics_Click
                If strImageFolder > "" Then Me.txtPicFolder.text = strImageFolder
            End If
        End If
    Else
        cmdConnect.Enabled = False
        txtDataFile.text = ""
        cboTables(0) = ""
        cboTables(0).Clear
        cboTables(0).Enabled = False
        cboTables(1) = ""
        cboTables(1).Clear
        cboTables(1).Enabled = False
        For i = 0 To 2
            FraOrder(i).Enabled = False
            cboFields(i) = ""
            cboFields(i).Clear
            cboFields(i).Enabled = False
            chkGrpHVis(i).value = 0
            chkGrpHVis(i).Enabled = False
            chkGrpFVis(i).value = 0
            chkGrpFVis(i).Enabled = False
        Next i
        chkHasPics.value = -blnHasPics
        chkHasPics_Click
        chkHasPics.Enabled = False
        txtPicFolder.text = ""
    End If

End Sub

Private Sub LoadSortFieldCombos()
Dim i As Integer

    For i = 0 To 2
        cboFields(i).Clear
        cboFields(i).Enabled = True
        cboFields(i).BackColor = vbWhite
    Next i
    
    For i = 0 To UBound(DataField) - 1
        cboFields(0).AddItem rstData.Fields(i).Name
        cboFields(1).AddItem rstData.Fields(i).Name
        cboFields(2).AddItem rstData.Fields(i).Name
    Next i
    
End Sub