frmprintdata.frm

远程访问sql server 的源码

VERSION 5.00
Begin VB.Form frmPrintData 
   Caption         =   "打印数据"
   ClientHeight    =   6900
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6315
   Icon            =   "frmPrintData.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6900
   ScaleWidth      =   6315
   StartUpPosition =   3  'Windows Default
   Begin VB.Frame fraPrint 
      Height          =   1575
      Left            =   4200
      TabIndex        =   14
      Top             =   5160
      Width           =   1575
      Begin VB.CommandButton cmdWord 
         Caption         =   "Word 打印"
         Enabled         =   0   'False
         Height          =   375
         Left            =   120
         TabIndex        =   16
         Top             =   120
         Width           =   1335
      End
      Begin VB.CommandButton cmdExcel 
         Caption         =   "Excel 打印"
         Enabled         =   0   'False
         Height          =   375
         Left            =   120
         TabIndex        =   15
         Top             =   1080
         Width           =   1335
      End
   End
   Begin VB.Frame fraStarPrint 
      Height          =   1575
      Left            =   480
      TabIndex        =   11
      Top             =   5160
      Width           =   1935
      Begin VB.CommandButton cmdExit 
         Caption         =   "退出"
         Height          =   375
         Left            =   120
         TabIndex        =   13
         Top             =   1080
         Width           =   1575
      End
      Begin VB.CommandButton cmdStartPrint 
         Caption         =   "打印设置完毕"
         DownPicture     =   "frmPrintData.frx":0442
         Height          =   375
         Left            =   120
         Picture         =   "frmPrintData.frx":0984
         TabIndex        =   12
         Top             =   120
         Width           =   1575
      End
   End
   Begin VB.CommandButton cmdMoves 
      Caption         =   "<<"
      Height          =   375
      Index           =   3
      Left            =   3000
      TabIndex        =   10
      Top             =   3720
      Width           =   375
   End
   Begin VB.CommandButton cmdMoves 
      Caption         =   "<"
      Height          =   375
      Index           =   2
      Left            =   3000
      TabIndex        =   9
      Top             =   3240
      Width           =   375
   End
   Begin VB.CommandButton cmdMoves 
      Caption         =   ">>"
      Height          =   375
      Index           =   1
      Left            =   3000
      TabIndex        =   8
      Top             =   2160
      Width           =   375
   End
   Begin VB.Frame fraField 
      Height          =   4095
      Left            =   480
      TabIndex        =   2
      Top             =   960
      Width           =   5295
      Begin VB.CommandButton cmdMoves 
         Caption         =   ">"
         Height          =   375
         Index           =   0
         Left            =   2520
         TabIndex        =   7
         Top             =   720
         Width           =   375
      End
      Begin VB.ListBox lstDest 
         BackColor       =   &H80000009&
         Height          =   3570
         Left            =   3120
         TabIndex        =   6
         Top             =   360
         Width           =   2055
      End
      Begin VB.ListBox lstSource 
         BackColor       =   &H80000009&
         Height          =   3570
         Left            =   120
         TabIndex        =   3
         Top             =   360
         Width           =   2055
      End
      Begin VB.Label lblDest 
         Caption         =   "目的字段列表"
         Height          =   255
         Left            =   4080
         TabIndex        =   5
         Top             =   120
         Width           =   1095
      End
      Begin VB.Label lblSource 
         Caption         =   "源字段列表"
         Height          =   255
         Left            =   120
         TabIndex        =   4
         Top             =   120
         Width           =   1095
      End
   End
   Begin VB.TextBox txtReportName 
      Height          =   495
      Left            =   1680
      TabIndex        =   1
      Top             =   240
      Width           =   4095
   End
   Begin VB.Label lblReportName 
      Caption         =   "报表表名："
      Height          =   375
      Left            =   480
      TabIndex        =   0
      Top             =   240
      Width           =   975
   End
End
Attribute VB_Name = "frmPrintData"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'返回处理结果，用来打印的记录集（属性变量）
Private mrsFrmPrintData As ADODB.Recordset

'接受传入的源记录集（属性变量）
Private mrsFrmSource As ADODB.Recordset
'数据库的链接对象
Private mcnnFrmConnect As ADODB.Connection
Private mstrSql As String

Const strReportHeader As String = "成绩查询结果"

Public Property Set cnnFrmConnect(ByVal vData As ADODB.Connection)
    Set mcnnFrmConnect = vData
End Property

Public Property Get cnnFrmConnect() As ADODB.Connection
    Set cnnFrmConnect = mcnnFrmConnect
End Property

Public Property Set rsFrmSource(ByVal vData As ADODB.Recordset)
    Set mrsFrmSource = vData
End Property

Public Property Get rsFrmSource() As ADODB.Recordset
    Set rsFrmSource = mrsFrmSource
End Property

Public Property Set rsFrmPrintData(ByVal vData As ADODB.Recordset)
    Set mrsFrmPrintData = vData
End Property

Public Property Get rsFrmPrintData() As ADODB.Recordset
    Set rsFrmPrintData = mrsFrmPrintData
End Property

Public Property Get strFrmSql() As String
    strFrmSql = mstrSql
End Property

Public Property Let strFrmSql(ByVal strData As String)
    mstrSql = strData
End Property

Private Sub cmdExcel_Click()
    '定义Excel对象
    Dim objExcel As Excel.Application '定义Excel对象
    Dim objWorkBook As Excel.Workbook '定义工作薄
    Dim objSheet As Excel.Worksheet '定义工作表
    Dim objRange As Excel.Range '定义用户使用工作表的范围
    
    Dim i As Integer, j As Integer
    Dim iCol As Integer, iRow As Integer
    
    Dim iChr As Integer '用来取得工作表中最后一个列的字符名，比如第H列
    Dim strChr As String
    
    On Error GoTo err
    '开始写入文件，鼠标显示沙漏，等待中……，同时显示状态栏
    Screen.MousePointer = vbHourglass
    
    If Not (rsFrmPrintData.EOF And rsFrmPrintData.BOF) Then
        rsFrmPrintData.MoveLast
        rsFrmPrintData.MoveFirst
        '用来设置Excel的行数和列数
        iRow = rsFrmPrintData.RecordCount + 1
        iCol = rsFrmPrintData.Fields.Count
    End If
    
    Set objExcel = New Excel.Application
    '添加新的工作薄，和新的工作表
    Set objWorkBook = objExcel.Workbooks.Add
    Set objSheet = objWorkBook.Worksheets.Add
    
    '取得最末列的字母
    iChr = Asc("A") + iCol - 1
    strChr = Chr(iChr) & 2
    
    For j = 1 To iCol
        With rsFrmPrintData.Fields(j - 1)
            If .Type = adChar Then
            '如果是字符型的字段，比较字段名的长度与字段定义长度哪个长，取长的设置为列宽度
                If LenB(StrConv(.Name, vbFromUnicode)) > .DefinedSize Then
                '此处用的方法是获取中英文混合字符串的精确长度（主要用来获取中文字符的长度）
                '然后将这个长度设置为每列的宽度
                    objSheet.Columns(j).ColumnWidth = LenB(StrConv(.Name, vbFromUnicode))
                Else
                    objSheet.Columns(j).ColumnWidth = .DefinedSize
                End If
            ElseIf .Type = adDouble Or .Type = adInteger Then
            '数值型的字段，直接取字段名的长度为列宽
                objSheet.Columns(j).ColumnWidth = LenB(StrConv(.Name, vbFromUnicode))
            End If
        End With
    Next j
    
    '设置将要操作的Excel的范围为从单元格A1到指定列数的单元格处
    '用了2行，用来写入报表的标题
    Set objRange = objSheet.Range("A1:" & strChr)
    objRange.Merge
    With objRange
        .Font.Name = "黑体"
        .Font.Size = 15
        .Cells(1, 1) = Trim$(txtReportName.Text) '"成绩查询结果"
        .Cells.HorizontalAlignment = xlCenter
        .Cells.VerticalAlignment = xlCenter
    End With
        
    '重新设定用来操作的工作表范围，用来写入数据库信息
    Set objRange = objSheet.Range("A3") '从A3开始重新设置范围写入数据
    
    With objRange
        '重新设定字体和字号
        .Font.Name = "宋体"
        .Font.Size = 12
    
        '利用行、列的双重循环，向单元格内写入数据，并指定其格式
        For i = 1 To iRow
            For j = 1 To iCol
                If i = 1 Then
                '第一行写表头
                    .Cells(i, j) = rsFrmPrintData.Fields(j - 1).Name
                    .Cells(i, j).HorizontalAlignment = xlCenter
                Else
                    With rsFrmPrintData.Fields(j - 1)
                        '如果是字符型的字段类型
                        If .Type = adChar Then
                'NumberFormatLocal属性：以用户语言字符串返回或设置对象的格式代码。String 类型，可读写。
                '在Excel中，单元格内默认的是数字类型，如果字符串开头有0，那么这个0将会被自动截去
                '想保留开头的0，那么需要设置单元格的格式为“文本”，下列语句实现这个功能
                            objRange.Cells(i, j).NumberFormatLocal = "@" '单元格类型为文本类型
                            
                            objRange.Cells(i, j) = CStr(Trim$(.Value))
                            '单元格内的数据，水平居中排列
                            objRange.Cells(i, j).HorizontalAlignment = xlCenter
                        ElseIf .Type = adDouble Or adInteger Then
                            objRange.Cells(i, j) = .Value
                            objRange.Cells(i, j).HorizontalAlignment = xlCenter
                        End If
                    
                    End With
                End If
            Next j
            
            If i > 1 Then 'i比记录总数多了1个，因此，从i＝2开始移动记录
                rsFrmPrintData.MoveNext
            End If
        Next i
    End With
    
    objExcel.Visible = True
    '写完文件，回复状态
    Screen.MousePointer = vbDefault
    Exit Sub
err:
    MsgBox err.Number & " " & err.Description
    '回复状态
    Screen.MousePointer = vbDefault
    '释放资源
    objWorkBook.Close