随笔-13  评论-29  文章-31  trackbacks-0
Private Sub nProcessPnt(iType As String) 'Print Line data
    On Error GoTo ErrHandling
   
    Screen.MousePointer = 11
   
    Dim myworkbook As Excel.Workbook
    Dim myworksheet As Excel.Worksheet
    Dim myworksheet2 As Excel.Worksheet
    Dim iRangeTmp As Excel.Range
 
    If Not RptXls Is Nothing Then
        If RptXls.Workbooks.count = 0 Then RptXls.Application.Quit
    End If
    Set RptXls = Nothing
    Set RptXls = CreateObject("excel.application")
    ExcelStatus = True
   
    RptXls.Visible = False
    If iType = "0" Then
        RptXls.Workbooks.Open FileName:=App.Path & "\rpt\OQC品質抽樣月報.xls", ReadOnly:=True
    Else
        RptXls.Workbooks.Open FileName:=App.Path & "\rpt\OQC品質抽樣月報.xls"
    End If
 
    RptXls.Application.DisplayAlerts = False
    Set myworkbook = RptXls.ActiveWorkbook
    Set myworksheet = myworkbook.Worksheets("sheet1")
    Set iRangeTmp = RptXls.ActiveCell
    myworksheet.Rows("1:1").HorizontalAlignment = xlCenter
   
    With grdData
        .Row = 0
        .Col = 0
        .RowSel = grdData.Rows - 1
        .ColSel = grdData.Cols - 1
         Clipboard.Clear
         Clipboard.SetText .Clip
         Clipboard.GetData
         myworksheet.Range("A3").Select
         myworksheet.Paste
    End With
    With grdData2
        .Row = 0
        .Col = grdData2.Cols - 1
        .RowSel = grdData2.Rows - 1
        .ColSel = grdData2.Cols - 1
         Clipboard.Clear
         Clipboard.SetText .Clip
         Clipboard.GetData
         myworksheet.Range("F4").Select
         myworksheet.Paste
    End With
    With grdData1
        .Row = 0
        .Col = 0
        .RowSel = grdData1.Rows - 1
        .ColSel = grdData1.Cols - 1
         Clipboard.Clear
         Clipboard.SetText .Clip
         Clipboard.GetData
         myworksheet.Range("A16").Select
         myworksheet.Paste
    End With
    With grdData4
        .Row = 0
        .Col = 0
        .RowSel = grdData4.Rows - 1
        .ColSel = grdData4.Cols - 1
         Clipboard.Clear
         Clipboard.SetText .Clip
         Clipboard.GetData
         myworksheet.Range("A22").Select
         myworksheet.Paste
    End With
   
    '將sheet2設為目前sheet add by mandy 2002/11/19
    Set myworksheet2 = myworkbook.Worksheets("Sheet2")
    myworkbook.Sheets("Sheet2").Select
    With grdData3
        .Row = 0
        .Col = 0
        .RowSel = grdData3.Rows - 1
        .ColSel = grdData3.Cols - 1
         Clipboard.Clear
         Clipboard.SetText .Clip
         Clipboard.GetData
         myworksheet2.Range("A1").Select
         myworksheet2.Paste
    End With
    '將C欄位全部置中對奇
'    myworksheet2.Columns("C:C").Select
'    With Selection
'        .HorizontalAlignment = xlCenter
'        .VerticalAlignment = xlBottom
'        .WrapText = False
'        .Orientation = 0
'        .AddIndent = False
'        .ShrinkToFit = False
'        .MergeCells = False
'    End With
    
    Clipboard.Clear
   
    myworkbook.Sheets("Sheet1").Select
 
   
    Call nSetPrintField(iRangeTmp)   '設定WorkSheet欄位值
   
    'Modify by Natasha 2001/12/28
    With myworksheet.PageSetup   '每頁皆設定表頭
        .PrintTitleRows = "$1:$2"
        .PrintTitleColumns = ""
        .RightHeader = "列印日期:&""Times New Roman,標準""&D" & Chr(10) & "&""新細明體,標準""頁次:&""Times New Roman,標準""&P/&N"
    End With
   
'    myworksheet.Columns("A:I").EntireColumn.AutoFit  '調整最適欄?    '為了報表美觀一點,加入此行,可調整最為適欄?
'    myworksheet.PageSetup.Orientation = xlLandscape  '橫印
    If iType = "1" Then     'Print
        dlgColor.Filter = "*.xls"
        dlgColor.FileName = ""
        dlgColor.ShowSave
        If dlgColor.FileName <> "" Then  '取消Save
            myworksheet.SaveAs dlgColor.FileName
            MsgBox gGetMessage("O1", "儲存"), vbInformation, Me.Caption
        End If
        myworkbook.Close
        If Not RptXls Is Nothing Then
            If RptXls.Workbooks.count = 0 Then RptXls.Application.Quit
        End If
        Set RptXls = Nothing
       
    Else                    'Preview
        RptXls.Visible = True
        RptXls.ActiveWindow.SelectedSheets.PrintPreview    '開啟Preview視窗
        Set RptXls = Nothing
    End If
       
    Screen.MousePointer = 0
 
    Exit Sub
 
ErrHandling:
    myworkbook.Close
    If Not RptXls Is Nothing Then
        If RptXls.Workbooks.count = 0 Then RptXls.Application.Quit
    End If
    Set RptXls = Nothing
    Screen.MousePointer = 0
    If Err = 20545 Then Exit Sub
    MsgBox gGetMessage("00", ""), vbExclamation, Me.Caption
    Exit Sub
End Sub
posted on 2005-10-28 15:42 生活像一团麻 阅读(1836) 评论(9)  编辑 收藏 引用 所属分类: 其他

评论:
# re: 操作Excel 代码 2010-04-19 19:27 | TashaFLOWERS
If you are in the corner and have no money to get out from that point, you would require to receive the <a href="http://lowest-rate-loans.com/topics/home-loans">home loans</a>. Because that will aid you for sure. I get bank loan every year and feel fine because of that.   回复  更多评论
  
# re: 操作Excel 代码 2010-05-27 23:56 | buy essays
Good information about this good post. I use the research paper writing services and buy essays or pre written essays about this good topic.   回复  更多评论
  
# re: 操作Excel 代码 2012-07-14 07:01 | application paper writing
Do you think that nobody can aid you with your academic papers proofreading? It is not correct, because essay writing service "supremeessays.com" company can help you anytime you want!   回复  更多评论
  
# re: 操作Excel 代码 2012-07-14 07:03 | essay money
I contacted many academic papers completing firms and could state that was hard to find reputed college essay writing service.   回复  更多评论
  
只有注册用户登录后才能发表评论。