Sub Demo_GetObject_Excel_Object_VB()
 
 'Demo zum öffnen und schließen von Excel mit VB
 'das Demo zum Verständnis im Schritt Modus ausführen
 'funzt nur wenn Excel auf dem Rechner installiert ist
 'unter Extras - Verweise:
 '        - MS Excel Object Library  einfügen
 'Dim xlsAppl As Excel.Application  'unterscheide diese Objectvariablen
 'Dim xlsWbk As Excel.Workbook   'unterscheide diese Objectvariablen
 'Wenn in deinenem Project der zugriff auf Excel in mehr als einer Procedur
 'nötig ist solltest du  xlsAppl und xlsWbk Global declarieren
 'Dim xlsWks As Excel.Worksheet
 'Wenn das Project auf anderen Rechnern eingesetzt werden soll
 'ist es besser wenn mann nach dem Testen mit dem "MS Excel Object Library"
 'die Objectvariablen so declariert:
 Dim xlsAppl As Object
 Dim xlsWbk As Object
 Dim xlsWks As Object
 'und den Verweis wieder entfernt. (!!!!)
 'Hierbei müssen ev. verwendete Excel Konstanten
 'durch dessen Werte ersetzt werden.
 
 Dim xlsPathAndFile$
 Dim xlsFile$
 Dim xPath$
 Dim WbkOffen As Boolean
 Dim GleichnamigeWbkOffen As Boolean
 Dim xlsApplLiefNicht As Boolean
 Dim xSpalte&
 Dim xZeile&
 Dim xDemo As Variant
 Dim Variable1 As Variant
 Dim xlChObj As Object  ' Excel.ChartObject
 Dim xlsShp As Object   'Excel.Shape
 
 'deine XLS
 xlsPathAndFile = "I:\test.xls"  'Beispiel
 
 xlsFile = Dir$(xlsPathAndFile, 0)
 If Len(xlsFile) < 4 Then
  MsgBox xlsPathAndFile & vbCr & "nicht vorhanden!!!"
  Exit Sub
 Else
  xPath = Mid(xlsPathAndFile, 1, Len(xlsPathAndFile) - Len(xlsFile) - 1)
 End If
 
 'Prüfen, ob Excel ausgeführt wird:
 'du hast sonst keine Möglichket auf den ersteren Task
 'zuzugreifen was bei mehrmaligem Zugriff zum Out of Memory führt
 'unter NT kann es sofort Fehler führen
 On Local Error Resume Next
  Set xlsAppl = GetObject(, "Excel.Application")
  If xlsAppl Is Nothing Then
   Set xlsAppl = GetObject(, "Excel.Application.8") 'Excel 97
  End If
 
 ''Wenn Excel nicht ausgeführt wird, Excel starten:
  If xlsAppl Is Nothing Then
   xlsApplLiefNicht = True
   Set xlsAppl = CreateObject("Excel.Application")
  End If
  If xlsAppl Is Nothing Then
   Set xlsAppl = CreateObject("Excel.Application.8") 'Excel 97
  End If
 
  'xlsAppl.DisplayAlerts = False 'Dies nur in begründeten Fällen verwenden
  If xlsAppl Is Nothing Then
   MsgBox "Es konnte keine Verbindung zur Excel Application aufgenommmen werden"
   Exit Sub
  End If
  Err.Clear   ' Err-Objekt im Fehlerfall löschen
 
  'Prüfen ob Workbook schon geöffnet:
 On Local Error Goto ErrHandler
 
 WbkOffen = False
 GleichnamigeWbkOffen = False
 For Each xlsWbk In xlsAppl.Workbooks
  If UCase(xlsWbk.Name) = UCase(xlsFile$) Then
   GleichnamigeWbkOffen = True
   If UCase(xlsWbk.Path) = UCase(xPath$) Then
    WbkOffen = True
    Exit For
   End If
  End If
 Next
 
 If GleichnamigeWbkOffen And Not WbkOffen Then
  MsgBox "Gleichnamige " & xlsFile$ & " bereits geöffnet"
  If xlsApplLiefNicht = True Then
   xlsAppl.Quit 'nicht vergessen
  Else
   xlsAppl.Visible = True
  End If
  Set xlsAppl = Nothing 'nie weglassen
  Exit Sub
 End If
 
 xlsAppl.EnableEvents = False
 '    'Wenn Arbeitsmappe nicht offen, öffnen:
 If Not WbkOffen And Not GleichnamigeWbkOffen Then
   Set xlsWbk = xlsAppl.Workbooks.Open(FileName:=xlsPathAndFile)
 End If
 xlsAppl.EnableEvents = True
 'oder neue  xlsWbk öffnen:
 'Set xlsWbk = xlsAppl.Workbooks.Add
 
 xlsAppl.Visible = False 'zum Testen: True

cu
JennyB
___________________________________________________________________
Some days are diamond - some days are stone ...