Office - Applications - Started!

With the following code the different Office applications (Word, PowerPoint, Access, Outlook) is started. It is examined whether application is already started. For each application there is a small example. Word - text mark put on and fill. PowerPoint - Slides put on and a range from Excel copy (picture, embedded object and metafile). Access - an empty data base is provided. Outlook - the number of mails in the inbox is spent. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1, Module2, Module3, Module4".


Mit folgendem Code werden die verschiedenen Office Anwendungen (Word, PowerPoint, Access, Outlook) gestartet. Es wird geprüft, ob die Anwendung schon gestartet ist. Für jede Applikation gibt es ein kleines Beispiel. Word - Textmarke anlegen und befüllen. PowerPoint - Slides anlegen und einen Bereich aus Excel kopieren (Bild, eingebettetes Objekt und Metafile). Access - eine leere Datenbank wird erstellt. Outlook - die Anzahl der Mails im Posteingang wird ausgegeben. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1, Modul2, Modul3, Modul4".


Option Explicit
Dim objWDD As Object
Dim objWD As Object
Dim strTMP As String
Public Sub Word_Bookmark()
Application.ScreenUpdating = False
On Error Resume Next
Set objWD = GetObject(, "Word.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objWD = CreateObject("Word.Application")
objWD.Visible = True
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objWD = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objWD = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_Word
Fin:
Set objWDD = Nothing
Set objWD = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_Word()
Set objWDD = objWD.Documents.Add
objWDD.Bookmarks.Add Name:="Test" ' adapt
With Sheet1 ' adapt
strTMP = .Cells(1, 1).Value & vbCrLf & _
.Cells(2, 1).Value & " " & .Cells(3, 1).Value
End With
objWDD.Bookmarks("Test").Range = strTMP
End Sub


Option Explicit
Dim objPPRange As Object
Dim objPPApp As Object
Dim objSlide As Object
Dim rngRange As Range
Public Sub PowerPoint_Slide()
On Error GoTo Fin
Application.ScreenUpdating = False
On Error Resume Next
Set objPPApp = GetObject(, "PowerPoint.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objPPApp = CreateObject("PowerPoint.Application")
objPPApp.Visible = True
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objPPApp = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objPPApp = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_PowerPoint
Fin:
Application.ScreenUpdating = True
Application.CutCopyMode = False
Set objPPRange = Nothing
Set objPPApp = Nothing
Set objSlide = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_PowerPoint()
Set rngRange = Sheet1.Range("A1:D10")
With objPPApp
.Visible = True
.Presentations.Add
.ActivePresentation.Slides.Add 1, 12
'Const ppLayoutBlank = 12
ThisWorkbook.Worksheets(rngRange.Parent.Name) _
.Range(rngRange.Address).CopyPicture
Set objSlide = .ActivePresentation.Slides(1)
Set objPPRange = objSlide.Shapes.Paste
With objPPRange
.Align 4, True
.Align 1, True
End With
Sheet1.Range(rngRange.Address).Copy
.ActivePresentation.Slides.Add 2, 12
'Const ppLayoutBlank = 12
.ActiveWindow.View.GotoSlide (2)
.ActiveWindow.View.PasteSpecial 10, , , , , -1
'Const ppPasteOLEObject = 10
.ActivePresentation.Slides.Add 3, 12
'Const ppLayoutBlank = 12
.ActiveWindow.View.GotoSlide (3)
.ActiveWindow.View.PasteSpecial 2
'Const ppPasteEnhancedMetafile = 2
End With
End Sub


Option Explicit
Dim strFileName As String
Dim objDataBase As Object
Dim objAcc As Object
Public Sub Access_Open()
Application.ScreenUpdating = False
On Error Resume Next
Set objAcc = GetObject(, "Access.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objAcc = CreateObject("Access.Application")
objAcc.Visible = False
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objAcc = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objAcc = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_Access
Fin:
Set objDataBase = Nothing
Set objAcc = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_Access()
strFileName = ThisWorkbook.Path & "\Test.mdb"
If Dir(strFileName) <> "" Then Kill (strFileName)
Set objDataBase = CreateObject(Class:="ADOX.Catalog")
objDataBase.Create "Provider=Microsoft.Jet.OLEDB.4.0; " _
& "Data Source=" & strFileName
MsgBox "Empty ""mdb"" in " & ThisWorkbook.FullName & _
"\Test.mdb" & " - and ACCESS is closed."
End Sub


Option Explicit
Dim objOutlook As Object
Public Sub Outlook_Open()
Application.ScreenUpdating = False
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
Select Case Err.Number
Case 429
Err.Clear
Set objOutlook = CreateObject("Outlook.Application")
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objOutlook = Nothing
Exit Sub
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objOutlook = Nothing
Exit Sub
End Select
On Error GoTo 0
On Error GoTo Fin
Call Do_Outlook
Fin:
Set objOutlook = Nothing
Application.ScreenUpdating = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Do_Outlook()
Dim myNameSpace As Object
Dim myFolder As Object
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6)
'Const olFolderCalendar = 9
'Const olFolderConflicts = 19 (&H13)
'Const olFolderContacts = 10
'Const olFolderDeletedItems = 3
'Const olFolderDrafts = 16 (&H10)
'Const olFolderInbox = 6
'Const olFolderJournal = 11
'Const olFolderJunk = 23 (&H17)
'Const olFolderLocalFailures = 21 (&H15)
'Const olFolderNotes = 12
'Const olFolderOutbox = 4
'Const olFolderSentMail = 5
'Const olFolderServerFailures = 22 (&H16)
'Const olFolderSyncIssues = 20 (&H14)
'Const olFolderTasks = 13
'Const olPublicFoldersAllPublicFolders = 18 (&H12)
MsgBox "There are " & myFolder.Items.Count & _
" mails in the inbox."
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...