Excel Application物件 開發指南

Application.Workbooks(1).Worksheets(1).Cells(1,1)=20

Set xl=CreateObject("Excel.Sheet")
xl.Application.Workbooks.Open "newbook.xls"

Sub ListAddIns()
     Dim myAddin As AddIn
     For Each myAddin In AddIns
          MsgBox myAddin.FullName
     Next
End Sub

Application.Columns(4).Select

Application.Rows(5).Select

Application.Sheets.PrintOut

For iSheet = 1 To Application.Sheets.Count
    If Not IsEmpty(Application.Sheets(iSheet).UsedRange) Then
           Application.Sheets(iSheet).PrintOut copies:=1
    End If
Next iSheet

Worksheets("Sheet1").Activate
With ActiveCell.Font
    .Bold = True
    .Italic = True
End With

Sub AddChart()
     Charts.Add
     With ActiveChart
         .ChartType = xl3DColumn
         .SetSourceData Source:=Sheets("Sheet1").Range("B3:H15")
         .Location Where:=xlLocationAsObject, Name:="Monthly Sales"
         .HasTitle = True
         .ChartTitle.Characters.Text = Monthly Sales by Category
     End With
End Sub

MsgBox "The name of the active sheet is " & ActiveSheet.Name

Sub CopyActiveSheet()
     Dim x As Integer
     x = InputBox("Enter number of times to copy active sheet")
     For numtimes = 1 To x
          ' Put copies in front of Sheet1.
          ActiveWorkbook.ActiveSheet.Copy _
             Before:=ActiveWorkbook.Sheets("Sheet1")
      Next
End Sub

MsgBox "The name of the active window is " & ActiveWindow.Caption

Sub PrintWorksheet()
      Application.ScreenUpdating = False
      Sheets("Sales").Select
      ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
      Sheets("Expenses").Select
      ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub

MsgBox "The name of the active workbook is " & ActiveWorkbook.Name

Sub CalcBook()
     Dim wks As Worksheet
     Application.Calculation = xlManual
     For Each wks In ActiveWorkbook.Worksheets
           wks.Calculate
     Next
     Set wks = Nothing
End Sub

MsgBox Application.ActiveWindow.RangeSelection.Address

Range("A1").Select
MsgBox Left(ActiveWindow.RangeSelection.Name.Name, 3)

ActiveWindow.RangeSelection.Name.Name

Worksheets("Sheet1").Activate Selection.Clear

NumRows = 0
For Each area In Selection.Areas
      NumRows = NumRows + area.Rows.Count
Next area

Sub Count_Selection()
Dim cell As Object
Dim count As Integer
count = 0
For Each cell In Selection
count = count + 1
Next cell
MsgBox count & " item(s) selected"
End Sub

Dim FileNum As Integer
FileNum = 0
For Each file in Files
' Do something here.
Application.StatusBar = "Now processing File " & FileNum
FileNum = FileNum + 1
Next

Application.StatusBar = False

Sub ShowStatusBarProgress()
Dim i As Long
Dim pctDone As Double
Dim numSquares As Long
Const MAXSQR As Long = 15
For i = 1 To 30
pctDone = i / 30
numSquares = pctDone * MAXSQR
Application.StatusBar = Application.Rept(Chr(31), numSquares)
Application.Wait Now + TimeSerial(0, 0, 1)
Next i
Application.StatusBar = False
End Sub

ThisWorkbook.Close SaveChanges:=False

Private oExcel As Excel.Application
Private wbk As Excel.Workbook
Sub CloseOpenWrkBks()
Dim wrkb As Workbook
For Each wbk In Application.Workbooks
If wrkb.Name <> ThisWorkbook.Name Then
wbk.Close True
End If
Next wbk
ThisWorkbook.Close True
End Sub

Sub OpenFile1( )
Dim bSuccess As Boolean
Msgbox "Please locate the MonthlySales.xls file."
bSuccess = Application.FindFile
If Not bSuccess Then
Msgbox "File not open."
End If
End Sub

Sub OpenFile2( )
Application.Dialogs(XlBuiltInDialog.xlDialogOpen).Show arg1:="Book1.xls"
End Sub

GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)

Dim fileToOpen As String
fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If fileToOpen <> "" Then
MsgBox "Open " & fileToOpen
End If

InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextID, Type)

Set myRange = Application.InputBox(prompt := "Sample", type := 8)

Sub PrintActiveSheet()
Dim TotalCopies As Long, NumCopies As Long
Dim sPrompt As String, sTitle As String
 
sPrompt = "How many copies do you want?"
sTitle = "Prints the active sheet"
TotalCopies = Application.InputBox(Prompt:=sPrompt, Title:=sTitle, Default:=1, Type:=1)
 
For NumCopies = 1 To TotalCopies
ActiveSheet.PrintOut
Next NumCopies
End Sub

Run(Macro, Arg1,    , Arg30)

Sub UseRunMethod()
Dim wks As Worksheet
Dim rng As Range
Set wks = Worksheets("Sheet2")
Set rng = wks.Range("A1:A10")
Application.Run "MyProc ", rng
' You could accomplish the same thing with:
' Call MyProc(rng)
End Sub
Sub MyProc(rng As Range)
With rng.Font
.Bold = True
End With
End Sub

Public WithEvents Apply As Application

Private Sub Apply_WorkbookOpen(ByVal Wb As Workbook)
       MsgBox "你開啟了工作簿。"
End Sub

Private Sub Appl_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
    MsgBox "你關閉了工作簿。"
End Sub

Dim ApplicationClass As New AppEventClass

Private Sub Workbook_Open()
Set ApplicationClass.Appl = Application
End Sub

Sub DeleteSheet()
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End Sub

Sub SaveWorksheet()
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "C:MonthlySales.xls"
Application.DisplayAlerts = True
End Sub

Sub SKeys()
Range("A1:D15").Copy ' Copy the range.
SendKeys "% n", True ' Minimize Excel.
Shell "notepad.exe", vbNormalFocus ' Start Notepad.
SendKeys "^V", True ' Past the range data into Notepad.
SendKeys "%FA", True ' Specify SaveAs.
SendKeys "SalesData.txt", True ' Provide a file name.
SendKeys "%S", True ' Save the file.
Close notepad
End Sub

Application.OnTime(EarliestTime, Procedure, LatestTime, Schedule)

Application.OnTime EarliestTime:= Now + TimeValue("00:05:00), _
Procedure := "YourProc"

Application.OnTime _
EarliestTime:=TimeValue("12:00:00"), _
Procedure:="YourProc"

Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:05:00"), "AutoSave"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime Now + TimeValue("00:05:00"), "CleanUp", , False
End Sub

Sub CreateNewWorkbook1()
    MsgBox "將建立一個新工作簿."
    Workbooks.Add
End Sub

Sub CreateNewWorkbook2()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Long
    MsgBox "將建立一個新工作簿,並預設工作表格式."
    Set wb = Workbooks.Add
    Set ws = wb.Sheets(1)
    ws.Name = "產品彙總表"
    ws.Cells(1, 1) = "序號"
    ws.Cells(1, 2) = "產品名稱"
    ws.Cells(1, 3) = "產品數量"
    For i = 2 To 10
        ws.Cells(i, 1) = i - 1
    Next i
End Sub

Sub testNewWorkbook()
    MsgBox "建立一個帶有10個工作表的新工作簿"
    Dim wb As Workbook
    Set wb = NewWorkbook(10)
End Sub
 
Function NewWorkbook(wsCount As Integer) As Workbook
    '建立帶有由變數wsCount提定數量工作表的工作簿，工作表數在1至255之間
    Dim OriginalWorksheetCount As Long
    Set NewWorkbook = Nothing
    If wsCount < 1 Or wsCount > 255 Then Exit Function
    OriginalWorksheetCount = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = wsCount
    Set NewWorkbook = Workbooks.Add
    Application.SheetsInNewWorkbook = OriginalWorksheetCount
End Function

Workbooks.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)

Sub openWorkbook2()
    Dim fname As String
    MsgBox "將D盤中的工作簿以只讀方式開啟"
    fname = "D:測試.xls"
    Workbooks.Open Filename:=fname, ReadOnly:=True
End Sub

Workbooks.Item(1)

Workbooks(1)

Workbooks("MyBook.xlsx")

Workbooks("Book2")

Workbooks("Book2.xlsx")

Workbooks("MyWorkbook").Activate

Workbooks.Count

Function MyName() As String
    MyName = ThisWorkbook.Name
End Function

Function MyName() As String
    MyName = ThisWorkbook.Name
End Function

Sub testGeneralWorkbookInfo()
    MsgBox "本工作簿的名稱為" & ActiveWorkbook.Name
    MsgBox "本工作簿帶完整路徑的名稱為" & ActiveWorkbook.FullName
    MsgBox "本工作簿物件的程式碼名為" & ActiveWorkbook.CodeName
    MsgBox "本工作簿的路徑為" & ActiveWorkbook.Path
    If ActiveWorkbook.ReadOnly Then
        MsgBox "本工作簿已經是以只讀方式開啟"
    Else
        MsgBox "本工作簿可讀寫."
    End If
    If ActiveWorkbook.Saved Then
        MsgBox "本工作簿已儲存."
    Else
        MsgBox "本工作簿需要儲存."
    End If
End Sub

Workbook.Save

Sub SaveAllWorkbooks()
    Dim wbk As Workbook
    For Each wbk In Workbooks
        If wbk.Path <> "" Then wbk.Save
    Next wbk
End Sub

Workbook.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local)

Sub AddSaveAsNewWorkbook()
    Dim Wk As Workbook
    Set Wk = Workbooks.Add
    Application.DisplayAlerts = False
    Wk.SaveAs Filename:="D:SalesData.xlsx"
End Sub

Sub SaveWorkbook2()
    Dim oldName As String, newName As String
    Dim folderName As String, fname As String
    oldName = ActiveWorkbook.Name
    newName = "new" & oldName
    MsgBox "將 & oldName & ">以 & newName & ">的名稱儲存"
    folderName = Application.DefaultFilePath
    fname = folderName & "" & newName
    ActiveWorkbook.SaveAs fname
End Sub

Sub CreateBak1()
    MsgBox "儲存工作簿並建立備份工作簿"
    ActiveWorkbook.SaveAs CreateBackup:=True
End Sub

Sub CreateBak2()
    MsgBox "儲存工作簿時,若已建立了備份,則將出現包含True的資訊框,否則出現False."
    MsgBox ActiveWorkbook.CreateBackup
End Sub

Workbook.SaveCopyAs(Filename)

Sub SaveWorkbookBackup()
    Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
    If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
    Set awb = ActiveWorkbook
    If awb.Path = "" Then
        Application.Dialogs(xlDialogSaveAs).Show
    Else
        BackupFileName = awb.FullName
        i = 0
        While InStr(i + 1, BackupFileName, ".") > 0
            i = InStr(i + 1, BackupFileName, ".")
        Wend
        If i > 0 Then BackupFileName = Left(BackupFileName, i - 1)
        BackupFileName = BackupFileName & ".bak"
        OK = False
        On Error GoTo NotAbleToSave
        With awb
            Application.StatusBar = "正在儲存工作簿..."
            .Save
            Application.StatusBar = "正在備份工作簿..."
            .SaveCopyAs BackupFileName
            OK = True
        End With
    End If
NotAbleToSave:
    Set awb = Nothing
    Application.StatusBar = False
    If Not OK Then
        MsgBox "備份工作簿未儲存!", vbExclamation, ThisWorkbook.Name
    End If
End Sub

Sub SaveWorkbookBackupToFloppyD()
    Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean
    If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub
    Set awb = ActiveWorkbook
    If awb.Path = "" Then
        Application.Dialogs(xlDialogSaveAs).Show
    Else
        BackupFileName = awb.Name
        OK = False
        On Error GoTo NotAbleToSave
        If Dir("D:" & BackupFileName) <> "" Then
            Kill "D:" & BackupFileName
        End If
        With awb
            Application.StatusBar = "正在儲存工作簿..."
            .Save
            Application.StatusBar = "正在備份工作簿..."
            .SaveCopyAs "D:" & BackupFileName
            OK = True
        End With
    End If
NotAbleToSave:
    Set awb = Nothing
    Application.StatusBar = False
    If Not OK Then
        MsgBox "備份工作簿未儲存!", vbExclamation, ThisWorkbook.Name
    End If
End Sub