frmprintdata.frm

远程访问sql server 的源码

    Set objSheet = Nothing
    Set objWorkBook = Nothing
    Set objExcel = Nothing
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Public Function GetRecordSet(strSql As String, conn As ADODB.Connection) As ADODB.Recordset
'功    能：获取ADO记录集
'参    数：
'          输入： strSQL        String     用于查询SQL数据库的SQL语句
'          输出： GetRecordSet  Recordset  返回的记录集

    On Error GoTo err
    Dim rsTemp As ADODB.Recordset
    Set rsTemp = New ADODB.Recordset
    Dim cnnTemp As ADODB.Connection
    
    Set cnnTemp = conn

    rsTemp.CursorType = adOpenKeyset
    rsTemp.LockType = adLockOptimistic
    rsTemp.Source = strSql
    Set rsTemp.ActiveConnection = cnnTemp
    rsTemp.Open
    
    Set GetRecordSet = rsTemp
    Exit Function
err:
    MsgBox err.Number & " " & err.Description
End Function

Private Sub cmdMoves_Click(Index As Integer)
    Dim nIndex As Integer
    Dim nCount As Integer
    Dim i As Integer
    
    Select Case Index
        Case 0 '>按钮
            '将选中的项添加到目的字段列表
            '同时将该项从源字段列表中删除
            nIndex = lstSource.ListIndex
            If nIndex >= 0 Then
                lstDest.AddItem lstSource.Text
                lstSource.RemoveItem nIndex
            End If
        Case 1 '>>按钮
            '将源字段列表中的内容全部添加到目的字段
            nCount = lstSource.ListCount
            If nCount > 0 Then
                For i = 0 To nCount - 1
                    lstDest.AddItem lstSource.List(i)
                Next i
                lstSource.Clear '清空源字段列表
            End If
        Case 2 '<按钮
            '将选中的项恢复到源字段列表
            '同时将该项从目的字段列表中删除
            nIndex = lstDest.ListIndex
            If nIndex >= 0 Then
                lstSource.AddItem lstDest.Text
                lstDest.RemoveItem nIndex
            End If
        Case 3 '<<按钮
            '将目的字段列表中的内容全部恢复到源字段
            nCount = lstDest.ListCount
            If nCount > 0 Then
                For i = 0 To nCount - 1
                    lstSource.AddItem lstDest.List(i)
                Next i
                lstDest.Clear
            End If
    End Select
    
    '设置打印按钮无效，因为设置有了变动
    '需要用“完成打印设置”按钮来重新激活这些按钮
    cmdWord.Enabled = False
    cmdExcel.Enabled = False
End Sub


Private Sub cmdStartPrint_Click()
    Dim nFldCountSource As Integer '原始记录集里字段数
    Dim nFldCountDest As Integer '目的列表里显示的字段数
    Dim strFldDest As String '将要选择的字段的连接字符串
    Dim i As Integer
    
    nFldCountSource = rsFrmSource.Fields.Count
    nFldCountDest = lstDest.ListCount
    
    '初始化选中字段字符串为空
    strFldDest = vbNullString
    '用来链接选中的字段名，形成新的字符串
    For i = 0 To nFldCountDest - 1
        If strFldDest = vbNullString Then
        '如果strFldDest开始是空值，那么将lstDest的第一项赋值给该字符串变量
            strFldDest = lstDest.List(i)
        Else
        '通过循环遍历lstDest中的所有条目，将这些字段名连接形成新的字符串
            strFldDest = strFldDest & "," & lstDest.List(i)
        End If
    Next i
    strFldDest = Trim$(strFldDest)
    
    strFrmSql = rsFrmSource.Source
    '利用Replace函数生成新的SQl语句，以获得用于打印的记录集
    strFrmSql = Replace(strFrmSql, "*", strFldDest)
    
    If nFldCountDest = 0 Then
        MsgBox "没有选择要打印的字段！"
        Exit Sub
    End If
    
    If nFldCountSource = nFldCountDest Then
        '如果源记录集中的字段数等于现在lstDest中的列表项数量
        '就直接使用源记录集去进行打印操作
        Set rsFrmPrintData = rsFrmSource
    Else
        '如果只是选择了某几个特定的字段进行打印，需要重新获得记录集
        Set rsFrmPrintData = GetRecordSet(strFrmSql, cnnFrmConnect)
    End If
    '激活打印按钮
    cmdWord.Enabled = True
    cmdExcel.Enabled = True
End Sub

Private Sub cmdWord_Click()
    '定义Word对象
    Dim objWord As New Word.Application
    Dim objDoc As New Word.Document
    Dim objTable As Word.Table '插入表格
    
    'Range对象引用文档中的某一连续区域。每个 Range 对象都是通过开始和结束字符位置来定义的。
    '在Visual Basic过程中使用 Range 对象可以定义文档的某一部分。一个 Range 对象小至只是一个插入点，
    '大至包括整篇文档。Range对象只在定义该对象的过程运行时才存在。

    'Start、End 和 StoryType 属性标识唯一一个 Range 对象。
    'Start 和 End 属性返回或设置 Range 对象的开始和结束字符位置。
    '在文档开头的字符位置为零，第一个字符之后的位置为 1，以此类推
    Dim objRange As Word.Range
    
    Dim i As Integer, j As Integer
    Dim iCol As Integer, iRow As Integer
    
    On Error GoTo err
    '开始写入文件，鼠标显示沙漏，等待中……，同时显示状态栏
    Screen.MousePointer = vbHourglass
    
    If Not (rsFrmPrintData.EOF And rsFrmPrintData.BOF) Then
        rsFrmPrintData.MoveLast
        rsFrmPrintData.MoveFirst
        '因为要包含表头，因此，行数要比记录数多1
        iRow = rsFrmPrintData.RecordCount + 1
        iCol = rsFrmPrintData.Fields.Count
    End If
    
    '打开一个新的文档
    Set objDoc = objWord.Documents.Add
    '设置范围为整个新文档的范围
    Set objRange = objDoc.Range
    
    'Selection对象代表一个窗格中的选定内容。该选定内容可以包括文档中的一个区域，
    '也可以仅包括插入点。
    '注意  每个窗格中只能有一个 Selection 对象，而且只能激活一个 Selection 对象

    With objWord.Selection
        .HomeKey Unit:=wdLine
        .ParagraphFormat.Alignment = wdAlignParagraphCenter '居中对齐
        .Font.Size = 15
        .Font.Name = "黑体"
        '将指定文本插入某一区域或所选内容的后面。应用本方法可以扩展原区域或所选内容，使其包含新文本。
        .InsertAfter Text:=Trim$(txtReportName.Text) '"成绩查询结果"
        
        '在区域或所选内容之后插入段落标记，
        '应用本方法后，原区域或所选内容将包含该新段落。
        .InsertParagraphAfter
        .InsertParagraphAfter
        .EndKey Unit:=5 '光标到行尾
    End With
    With objWord.Selection
        .Font.Size = 12
        .Font.Name = "宋体"
        
        '在Word文档中添加一个Table对象，指明其行数和列数
        Set objTable = .Tables.Add(Range:=.Range, NumRows:=iRow, _
            NumColumns:=iCol, DefaultTableBehavior:=wdWord9TableBehavior, _
            AutoFitBehavior:=wdAutoFitFixed)
        
        '设置表格边框样式
        With objTable.Borders
            .InsideLineStyle = wdLineStyleSingle
            .OutsideLineStyle = wdLineStyleDouble
        End With
        
        For i = 1 To iCol
        'PreferredWidthType是用来指定单元格、列或表格的首选宽度的度量单位。
            objTable.Columns(i).PreferredWidthType = wdPreferredWidthAuto
        Next i
        
        For i = 1 To iRow
            For j = 1 To iCol
            '往每个表格的单元中插入文本，每次输完一行
                If i = 1 Then
                '当是表的第一行时，输入字段名
                    objTable.Cell(i, j).Range.InsertAfter rsFrmPrintData.Fields(j - 1).Name
                Else
                '从表的第二行开始，输入记录
                    objTable.Cell(i, j).Range.InsertAfter rsFrmPrintData.Fields(j - 1).Value
                End If
            Next j
            
            If i > 1 Then 'i比记录总数多了1个，因此，从i＝2开始移动记录
                rsFrmPrintData.MoveNext
            End If
        Next i
    End With
    
    '设置表格居中，然而段落中的居中方式不能起作用，因此，利用选中表格对象
    '再利用工具栏里，工具栏中的“格式”栏目中的居中对齐按钮来完成居中工作！
    '该按钮的索引号是14。对于中文版的Word，其名称为"居中(&C)"
    objTable.Select
    
    '直接执行控件集合中特定控件的Execute方法，使其执行
    objWord.CommandBars("Formatting").Controls("居中(&C)").Execute
    
    objWord.Selection.Collapse
    '参数Direction:=wdCollapseStart将会将插入点折叠到被选区域的起始位置,
    '默认情况则在被选区域的后面设置插入点
    '该语句取消了程序中的选择区域
    
    objWord.Visible = True
    
    '写完文件，回复状态
    Screen.MousePointer = vbDefault
    Exit Sub
err:
    MsgBox err.Number & " " & err.Description
    '回复状态
    Screen.MousePointer = vbDefault
    objDoc.Close
    Set objDoc = Nothing
    Set objWord = Nothing
End Sub

Private Sub Form_Load()
    '定义存放字段数量的变量
    Dim fldCount As Integer
    Dim i As Integer
    
    Move (Screen.Width - Me.Width) / 2, _
        (Screen.Height - Me.Height) / 2
    '先用默认字符串设置将来要写入报表名称的文本框
    txtReportName.Text = strReportHeader
    
    '清空列表框
    lstSource.Clear
    lstDest.Clear
    
    fldCount = rsFrmSource.Fields.Count
    
    '将传入的记录集中所有字段加入源字段列表框中
    With rsFrmSource
        For i = 0 To fldCount - 1
            lstSource.AddItem .Fields(i).Name
        Next i
    End With
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    'QueryUnload非常重要，能在用户要退出窗体的时候，给出提示
    '这对于包含重要信息和数据的程序来说，增加了安全性
    Dim strMsg As String
    Dim iMsg As Integer
    strMsg = "请确认是否要退出打印窗体！"
    iMsg = MsgBox(strMsg, vbYesNo)
    Select Case iMsg
        Case vbYes
            Cancel = False
        Case vbNo
            Cancel = True
    End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
    '如果在此处关闭源记录集，那么查询结果窗体上的记录集也被关闭
    '因为，这些记录集变量指针指向的是同一个对象
    'rsFrmSource.Close
    'Set rsFrmSource = Nothing
    
    On Error Resume Next
    cnnFrmConnect.Close
    Set cnnFrmConnect = Nothing
End Sub

Private Sub lstDest_DblClick()
    '双击列表项，取得列表框条目的索引，然后根据索引完成传递
    Dim iIndex As Integer
    
    iIndex = lstDest.ListIndex
    If iIndex >= 0 Then
        '源与目的的添加和删除需要同步进行
        lstSource.AddItem lstDest.Text
        lstDest.RemoveItem iIndex
    End If
End Sub

Private Sub lstSource_DblClick()
    '双击列表项，取得列表框条目的索引，然后根据索引完成传递
    Dim iIndex As Integer
    
    iIndex = lstSource.ListIndex
    If iIndex >= 0 Then
        '源与目的的添加和删除需要同步进行
        lstDest.AddItem lstSource.Text
        lstSource.RemoveItem iIndex
    End If
End Sub