Anzeige
Archiv - Navigation
1108to1112
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

in andere App kopieren

in andere App kopieren
bernd
ich noch einmal....
also ich habe da doch noch ein problem von einer excelinstanz in die andere zu kopieren.
ich kann zwar mit AppActivate die zweite excelinstanz aktivieren, aber ich bin unfähig
daten hineinzukopieren :(
die antwort aus dem forum geht leider nicht
( https://www.herber.de/forum/archiv/1104to1108/t1104660.htm
)
viele grüße
bernd

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: in andere App kopieren
08.10.2009 20:45:43
Ramses
Hallo
zeig doch mal wie du die zweite Instanz aktivierst
Gruss Rainer
AW: in andere App kopieren
08.10.2009 21:04:51
bernd
AppsActivate"Microsoft Excel Test.xls"
Da hilt gar nicht ....
08.10.2009 21:23:30
Ramses
Hallo
du musst schon die andere Instanz einem Object zuweisen, damit du die darin enthaltenen Workbooks / Worksheets auch ansprechen kannst.
Mit deiner Anweisung wird ja nur das entsprechende Fenster aktiviert. Sobald das Fenster den Focus hat, funktioniert ja dein Makro nicht mehr.
Hier mal etwas zum ausprobieren
Option Explicit
'Listet alle aktiven Fenter / Applikation auf
Private Declare Function GetWindow Lib "User32" _
    (ByVal appWnd As Long, ByVal wCmd As Long) As Long

Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" _
    (ByVal appWnd As Long, ByVal wIndx As Long) As Long

Private Declare Function GetWindowTextLength Lib "User32" Alias "GetWindowTextLengthA" _
    (ByVal appWnd As Long) As Long

Private Declare Function GetWindowText Lib "User32" Alias "GetWindowTextA" _
    (ByVal appWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
    (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long



Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2
Const GWL_STYLE = (-16)
Const WS_VISIBLE = &H10000000
Const WS_BORDER = &H800000


Private Function GetWindowTitle(ByVal appWnd As Long) As String
    Dim appResult As Long, appTempStr As String
    appResult = GetWindowTextLength(appWnd) + 1
    appTempStr = Space(appResult)
    appResult = GetWindowText(appWnd, appTempStr, appResult)
    GetWindowTitle = Left(appTempStr, Len(appTempStr) - 1)
End Function

Sub CheckWindow()
    Dim x As Variant
    Dim AppName As String
    Dim Qe As Integer
    'Mit Parameter 0 wird nur True oder False
    'bei der Suche nach dem Programm Namen zurückgegeben
    'Mit Parameter 1 erfolgt die Ausgabe aller
    'gefundenen Fenster in eine MsgBox
    AppName = "Excel"
    AppName = InputBox("Bitte geben Sie die Applikation ein, die gesucht werden soll", _
    "Suche nach geöffneter Applikation", AppName)
    Qe = MsgBox("Soll nur geprüft werden ob die Application: " & AppName & " geöffnet ist?", _
    vbQuestion + vbYesNo, "Prüfung")
    If Qe = vbYes Then
        MsgBox "Applikation: """ & AppName & """ ist geöffnet: " & GetWindowList(AppName, 0)
    Else
        x = GetWindowList("EXCEL", 1)
    End If
End Sub

Public Function GetWindowList(findApp As String, kindMsg As Integer) As Boolean
    'Gibt True zurück wenn die Applikation aktiv ist
    Dim app() As Long
    Dim appWnd As Long, appTitle As String, appStyle As Long, appTask_name() As String
    Dim appCount As Integer, appIndex As Integer, appFound As Boolean
    Dim msgTxt As String
    appWnd = FindWindow(ByVal 0&, ByVal 0&)
    appWnd = GetWindow(appWnd, GW_HWNDFIRST)
    '1. Initialisierung
    GetWindowList = False
    Do
        'Loop starten durch alle geöffneten Fenster
        appFound = False
        appStyle = GetWindowLong(appWnd, GWL_STYLE)
        appStyle = appStyle And (WS_VISIBLE Or WS_BORDER)
        appTitle = GetWindowTitle(appWnd)
        'Alle gefundenen Applicationen in einen Array aufnehmen
        If (appStyle = (WS_VISIBLE Or WS_BORDER)) = True Then
            If Trim(appTitle) <> "" Then
                For appIndex = 1 To appCount
                    If appTask_name(appIndex) = appTitle Then
                        appFound = True
                        Exit For
                    End If
                Next appIndex
                If Not appFound Then
                    appCount = appCount + 1
                    ReDim Preserve appTask_name(1 To appCount)
                    appTask_name(appCount) = appTitle
                    ReDim Preserve app(1 To appCount)
                    app(appCount) = appWnd
                End If
            End If
        End If
        appWnd = GetWindow(appWnd, GW_HWNDNEXT)
    Loop Until appWnd = 0
    'Durchsuchen des erstellten Arrays nach der Application
    If kindMsg = 0 Then
        For appIndex = 1 To appCount
            'Es wird nur der übergebene String in "appTask_Name" gesucht
            'Die Instanz selbst wird nicht identifiziert.
            'Dazu müsste noch der String "Microsoft" geprüft werden
            If InStr(1, appTask_name(appIndex), findApp) > 1 Then
                'Application gefunden = Ende der Schleife
                GetWindowList = True
                Exit Function
            End If
        Next appIndex
        ElseIf kindMsg = 1 Then
        For appIndex = 1 To appCount
            msgTxt = msgTxt & "Aktiv: " & appTask_name(appIndex) & Chr$(13)
        Next appIndex
        MsgBox msgTxt
        GetWindowList = True
    End If
End Function


Function Check_Open_Application(AppName As String) As Boolean
    'Test Function
    If GetWindowList(AppName) Then
        Check_Open_Application = True
    Else
        Check_Open_Application = False
    End If
End Function


Sub Start_Run_Check()
    If Check_Open_Application(InputBox _
        ("Geben Sie den Programmtitel ein." & Chr$(13) & _
        "ACHTUNG: Case Sensitiv !!", "Suche Application", "Excel")) = True Then
        Debug.Print "Test erfolgreich"
    Else
        Debug.Print "Test nicht erfolgreich"
    End If
End Sub


Sub Open_Test_File()
    Dim s$, AppExec As Long
    s = "c:\test.txt"
    If GetWindowList("Editor") Then
        'AppExec = ShellExecute(2140, vbNullString, s, "", "", 1)
        Debug.Print "OK"
    Else
        MsgBox "Applikation nicht aktiv"
    End If
End Sub

Hast du eine Instanz gefunden, musst du natürlich prüfen, OB in dieser Instanz auch DEINE von dir GESUCHTE Mappe ist,... denn das ist ja nicht gesichtert
Gruss Rainer
Anzeige
AW: in andere App kopieren
09.10.2009 00:10:01
Jürgen
Hallo Bernd,
für das Kopieren von Daten aus einer in eine andere Datei ist das Wechseln von Fenster / Markieren von Zellen nicht notwendig (auch wenn die beiden Dateien in einer Excel-Instanz geöffnet sind)! Damit reduziert sich Dein Problem auf das Öffnen einer zweiten Excelinstanz (Lösung s.u.). Leider funktioniert nach meinen Tests das Kopieren von einer in die andere Excel-Instanz per Copy bzw. Copy/paste nicht. Daher könnte eine Lösung so aussehen (kopiert den Inhalt des ersten Arbeitsblatts der Datei, die das Makro enthält, in eine neue Datei in einer zweiten Excel-Instanz, speichert diese und schließt die Datei und die Excel-Instanz) :
Sub Kopieren()
Dim XLApp2 As Application
Dim Zieldatei As Workbook
Set XLApp2 = CreateObject("excel.application")
Set Zieldatei = XLApp2.Workbooks.Add
Zieldatei.Sheets(1).Range(ThisWorkbook.Sheets(1).UsedRange.Address).Value = ThisWorkbook.Sheets( _
1).UsedRange.Value
Zieldatei.SaveAs ThisWorkbook.Path & "\Test.xls"
Zieldatei.Close False
Set Zieldatei = Nothing
XLApp2.quit
Set XLApp2 = Nothing
End Sub

Wenn eine bestehende Excel-Datei in der 2. Instanz geöffnet wird, könnte die Lösung so aussehen:
Sub Kopieren2()
Dim XLApp2 As Application
Dim ZieldateiName As String
ZieldateiName = "test.xls"
Set XLApp2 = CreateObject("excel.application")
XLApp2.Workbooks.Open ThisWorkbook.Path & "\" & ZieldateiName
XLApp2.Workbooks(ZieldateiName).Sheets(1).Range(ThisWorkbook.Sheets(1).UsedRange.Address).Value  _
= ThisWorkbook.Sheets(1).UsedRange.Value
XLApp2.Workbooks(ZieldateiName).Save
XLApp2.Workbooks(ZieldateiName).Close False
XLApp2.Quit
Set XLApp2 = Nothing
End Sub

Gruß, Jürgen
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige