请问如何用VB生的EXECL报表保存到计算机上??

Question

Dim oExcel As Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Private Conn As ADODB.Connection
Private Sub CmdExcel_Click()
frmOQCRept.MousePointer = vbHourglass
On Error Resume Next
'===================================================================
'創建對象
'===================================================================
Set oExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
       Set oExcel = CreateObject("Excel.Application")
End If
Err.Clear
oExcel.Visible = False
oExcel.ScreenUpdating = False
Set oBook = oExcel.Workbooks.Add
Set oSheet = oBook.Worksheets(1)
'===================================================================
Call InitExcel
Call InsertExcel
CommonDialog1.ShowSave
oBook.SaveAs CommonDialog1.FileName + ".xls"
frmOQCRept.MousePointer = vbArrow
MsgBox "轉化成功"
'oExcel.Visible = True
If oExcel.Workbooks.Count >= 1 Then
     Set oSheet = Nothing
    oBook.Close False
    Set oBook = Nothing
End If
    oExcel.Quit
    Set oExcel = Nothing
Exit Sub
End Sub
'===================================================================
'初始化EXCEL文件
'===================================================================
Private Sub InitExcel()
    With oSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .PrintArea = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.12)
        .RightMargin = Application.InchesToPoints(0.12)
        .TopMargin = Application.InchesToPoints(0.4)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.12)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 68
    End With
    
    With oSheet.Cells.Font   ' Set All Cells Format
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
    With oSheet.Cells
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .RowHeight = 15
    End With    Range(Cells(1, 1), Cells(1, FGrid1.Cols - 1)).Select
    ActiveCell.FormulaR1C1 = "鎂合金OQC報表"
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    Selection.Merge
    
    Range(Cells(2, 1), Cells(2, 4)).Select
    ActiveCell.FormulaR1C1 = "日期:" + CStr(DTPFromDate.Value) + "至" + CStr(DTPToDate.Value)
    Selection.Merge
    Range(Cells(2, FGrid1.Cols - 4), Cells(2, FGrid1.Cols - 1)).Select
    ActiveCell.FormulaR1C1 = "表單編號:" + CmbReptNO.Text
    Selection.Merge
    
    Range(Cells(3, 1), Cells(3, 1)).Select
    ActiveCell.FormulaR1C1 = "機種"
End Sub'===================================================================
'往EXCEL文件里添加數據
'===================================================================
Private Sub InsertExcel()
Dim i As Integer
Dim j As IntegerFor i = 1 To FGrid1.Rows - 1 Step 5
    oSheet.Range(Cells(i + 3, 1), Cells(i + 5, 1)).Select
    ActiveCell.FormulaR1C1 = FGrid1.TextMatrix(i, 0)
    Selection.Merge
    oSheet.Cells(i + 6, 1) = FGrid1.TextMatrix(i + 3, 0)
    oSheet.Cells(i + 7, 1) = FGrid1.TextMatrix(i + 4, 0)
Next i
For i = 0 To FGrid1.Rows - 1
    FGrid1.row = i
    For j = 1 To FGrid1.Cols - 1
        FGrid1.col = j
        oSheet.Cells(i + 3, j + 1).Value = FGrid1.Text  'EXCEL文件有倆行表頭,而且是以第1行第一列開始計算,所以行加3而列加1
    Next j
Next i
'====================================================================
'加邊框
'====================================================================
    Range(Cells(3, 1), Cells(i + 2, j)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub
'===================================================================
Private Sub Command1_Click()
    frmOQCRept.MousePointer = vbHourglass
    FGrid1.Clear
    SetFGrid
    ShowFGrid1
End Sub

Answer 1

Private Sub Form_Load()
    DTPFromDate.Value = CStr(Date - 6)
    DTPToDate.Value = CStr(Date)
    Set Conn = New ADODB.Connection
    Conn.ConnectionString = ConnDBString
    Conn.CursorLocation = adUseClient
    Conn.Open
    SetFGrid
    AddSingleItemToComb CmbReptNO, "Select ReptNO From ReportNO Where DelFlag='0'", ""
End Sub
Private Sub Form_Resize()
    If Me.Width > 60 And Me.Height > 1100 Then
        FGrid1.Width = Me.Width - 60
        FGrid1.Height = Me.Height - 1100
        Picture1.Width = Me.Width
    End If
End SubPrivate Sub SetFGrid()
    Dim BOMRs As ADODB.Recordset  '抓出料號機種
    Dim i As Integer
    If DTPToDate.Value < DTPFromDate.Value Then
        MsgBox "開始日期不能大於結束日期"
        Exit Sub
    End If
    '算出間隔的天數
    Days = DTPToDate.Value - DTPFromDate.Value + 1
        
    With FGrid1
        .Cols = Days + 3
        '===========================
       '頭一行,顯示日期
       '===========================
       '定義合併樣式
       .MergeCells = flexMergeFree
       .row = 0
       .col = 0
       .ColAlignment(0) = 4
       .ColWidth(0) = 2000
       .Text = "機種"
       .col = 1
       .ColWidth(1) = 1200
       .Text = "項次\日期"
       
       For i = 2 To .Cols - 2
            .col = i
            .TextMatrix(0, i) = CStr(DTPFromDate.Value + i - 2)
            .ColAlignment(i) = 4
            .ColWidth(i) = 1000
       Next i
       .col = i
       .TextMatrix(0, i) = "Total"
       .ColAlignment(i) = 4
    End With
    
    '=======================================================================
    '列表頭
    '=======================================================================
    With FGrid1
        
        .MergeCol(0) = True
        Set BOMRs = New ADODB.Recordset
        BOMRs.Open "Select distinct  A.BOMNO,B.ModelName,A.ModelNO From OQCDetail A join BOM B On (A.BOMNO=B.BOMNO and A.ModelNO=B.ModelNO) Where A.InputDate Between '" + CStr(DTPFromDate.Value) + "' and '" + CStr(DTPToDate.Value) + "'", Conn, adOpenStatic, adLockReadOnly
        If Not BOMRs.EOF Then
            .Rows = 5 * BOMRs.RecordCount + 1 '每個料號對應5個項次
            For i = 1 To .Rows - 1 Step 5
                .row = i
                .TextMatrix(i, 0) = BOMRs("ModelName")
                .TextMatrix(i, 1) = "檢驗數量"
                .TextMatrix(i + 1, 0) = BOMRs("ModelName")
                .TextMatrix(i + 1, 1) = "不良數"
                .TextMatrix(i + 2, 0) = BOMRs("ModelName")
                .TextMatrix(i + 2, 1) = "不良率"
                .TextMatrix(i + 3, 0) = BOMRs("BOMNO")
                .TextMatrix(i + 3, 1) = "批退率"
                .TextMatrix(i + 4, 0) = BOMRs("ModelNO")
                .TextMatrix(i + 4, 1) = "出貨數"
                BOMRs.MoveNext
            Next i
        Else
            .Rows = 1
        End If
        BOMRs.Close
    End With
End SubPrivate Sub ShowFGrid1()
    Dim strSql, strsql1 As String
    Dim i As Integer
    Dim j As Integer
    Dim totalErrCountByDpt As Integer
    Dim PiCount As String  '定義批數和不良批數
    Dim BadPiCount As String
    Dim ncol As Integer '當前所在的列數位置
    '===================================================================
    '抓當前日期
   '=====================對當前日期來填充表格==============================================
    With FGrid1
        For i = 1 To .Rows - 1 Step 5
            For j = 2 To .Cols - 2
                '第二行
                .TextMatrix(i, j) = GetOQCCount("OQCCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, j), .TextMatrix(0, j))
                '第三行
                .TextMatrix(i + 1, j) = GetOQCCount("BadCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, j), .TextMatrix(0, j))
                '第四行
                If .TextMatrix(i + 1, j) <> "" And .TextMatrix(i, j) <> "" Then
                    .TextMatrix(i + 2, j) = GetRate(.TextMatrix(i, j), .TextMatrix(i + 1, j)) & "%"
                End If
                '=============================================
                '第五行
                PiCount = GetOQCCount("PiCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, j), .TextMatrix(0, j))
                BadPiCount = GetOQCCount("BadPiCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, j), .TextMatrix(0, j))
                If PiCount <> "" And BadPiCount <> "" Then
                    .TextMatrix(i + 3, j) = GetRate(PiCount, BadPiCount) & "%"
                End If
                '=============================================
                '第六行
                .TextMatrix(i + 4, j) = GetOQCCount("ShipmentCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, j), .TextMatrix(0, j))
                
            Next j
            .TextMatrix(i, j) = GetOQCCount("OQCCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, 2), .TextMatrix(0, .Cols - 2))
            .TextMatrix(i + 1, j) = GetOQCCount("BadCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, 2), .TextMatrix(0, .Cols - 2))
            If .TextMatrix(i, j) <> "" And .TextMatrix(i + 1, j) <> "" Then
                .TextMatrix(i + 2, j) = GetRate(.TextMatrix(i, j), .TextMatrix(i + 1, j)) & "%"
            End If
            '=============================================
            '第五行
            PiCount = GetOQCCount("PiCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, 2), .TextMatrix(0, .Cols - 2))
            BadPiCount = GetOQCCount("BadPiCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, 2), .TextMatrix(0, .Cols - 2))
            If PiCount <> "" And BadPiCount <> "" Then
                .TextMatrix(i + 3, j) = GetRate(PiCount, BadPiCount) & "%"
            End If
            '=============================================
            .TextMatrix(i + 4, j) = GetOQCCount("ShipmentCount", .TextMatrix(i + 3, 0), .TextMatrix(i + 4, 0), .TextMatrix(0, 2), .TextMatrix(0, .Cols - 2))
        Next i
     End With    frmOQCRept.MousePointer = vbArrow
End Sub