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

Bild aus bereits geöffneten IE importieren

Forumthread: Bild aus bereits geöffneten IE importieren

Bild aus bereits geöffneten IE importieren
Andy
Hallo,
ich komme an folgendem Punkt nicht weiter. Es soll ein Bild einer bereits geöffneten Website mittels VBA in excel übertragen werden (evtl auch gepasted). Nun habe ich hierbei zwei Probleme:
1. Es können mehrere Browser Fenster offen sein. Fragmente des des gewollten Browserfensters müssen im Script definierbar sein.
2. Der Dateiname des Bildes ist immer ähnlich (enthält bsp.-weise rnd zahlen: " 30234282_picture798.jpg), aber nie gleich. Auch hier muss ein Fragment des Dateinamen im Script definierbar sein (*_picture*.jpg)
3. Ich finde überall nur die Funktion CreateObject("InternetExplorer.Application") aber nicht GetObject("InternetExplorer.Application")
Mein jetziges Script sieht bis jetzt so aus:
Macht aber eigentlich was ganz anderes :-))) 
Sub test()
Dim appIE, Inhalt As String, Bild, B, posKL, posAZ, pos, Anz
Dim Endg, E
Endg = Array(".gif", ".jpg")
Const Url As String = "https://www.google.de"
Set appIE = CreateObject("InternetExplorer.Application")
With appIE
.Visible = True
.Navigate Url
While .Busy
Wend
Inhalt = .Document.DocumentElement.innerhtml
appIE.Quit
Columns(1).ClearContents
For E = 0 To UBound(Endg)
Bild = Split(Inhalt, Endg(E))
For B = 0 To UBound(Bild)
If Right(Bild(B), 1)  ">" Then
posKL = InStrRev(Bild(B), "(") 'Klammer
posAZ = InStrRev(Bild(B), Chr(34)) 'Anführungszeichen
pos = IIf(posKL > posAZ, posKL, posAZ)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(Anz + 1, 1), Address:= _
Url & Mid(Bild(B), pos + 1) & Endg(E), TextToDisplay:= _
Url & Mid(Bild(B), pos + 1) & Endg(E)
Anz = Anz + 1
End If
Next B
Next E
End With
Set appIE = Nothing
End Sub

Kann mir da jemand helfen?
Oder ist das gar nicht möglich?
Danke
Andy
Anzeige
AW: Bild aus bereits geöffneten IE importieren
17.04.2010 12:43:57
Tino
Hallo,
vielleicht geht es so.
Verstehe nur nicht wieso die Seite zuvor offen sein muss.
Datei muss zuvor gespeichert sein, dort werden auch die Bilder temporär abgelegt.
kommt als Code in Modul1 
Option Explicit 
 
Sub test() 
Dim appIE As InternetExplorer, oImage As Object 
Dim ArBilderName 
Dim lngRow&, nCount%, TopPic As Double 
Dim Ziel$ 
Dim oPic As Picture 
 
Ziel = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") 
Ziel = Ziel & "tmpImage" 
 
ArBilderName = Array("*.gif", "*.jpg") 
 
Const Url As String = "http://www.google.de/" 
 
Set appIE = Find_IE(Url) 
If appIE Is Nothing Then 
    MsgBox "Webseite nicht geöffnet" 
    Exit Sub 
End If 
 
With Sheets("Tabelle1") 
    .Pictures.Delete 
    lngRow = 2 
    .Range("A2", .Cells(.Rows.Count, 1)).Clear 
    TopPic = Cells(lngRow, 1).Top 
    For Each oImage In appIE.Document.images 
        For nCount = Lbound(ArBilderName) To Ubound(ArBilderName) 
            If oImage.href Like ArBilderName(nCount) Then 
                DownloadFile oImage.href, Ziel 
                Set oPic = .Pictures.Insert(Ziel) 
                oPic.Top = TopPic 
                oPic.Left = Cells(lngRow, 1).Width / 2 
                TopPic = oPic.Top + oPic.Height + 10 
                Kill Ziel 
            End If 
        Next nCount 
    Next oImage 
End With 
 
Set appIE = Nothing 
End Sub
kommt als Code in Modul2 
Option Explicit 
 
Function Find_IE(ByVal strAdresse$) As Object 
Dim objShell As Object, oApp As Object 
Dim strTmpAdresse$ 
Set objShell = CreateObject("Shell.Application") 
   
If Right$(strAdresse, 1) = "/" Then 
    strTmpAdresse = Left$(strAdresse, Len(strAdresse) - 1) 
Else 
    strTmpAdresse = strAdresse & "/" 
End If 
   
For Each oApp In objShell.Windows 
  If InStr(UCase(oApp.FullName), "IEXPLORE") > 0 Then 
    If oApp.Document.Location = strAdresse$ Or oApp.Document.Location = strTmpAdresse$ Then 
      Set Find_IE = oApp 
      Exit For 
    End If 
  End If 
Next 
Set objShell = Nothing 
End Function
kommt als Code in Modul3 
Option Explicit 
 
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
ByVal pCaller&, _
ByVal szURL$, _
ByVal szFileName$, _
ByVal dwReserved&, _
ByVal lpfnCB&) As Long 
 
Public Function DownloadFile(ByVal strURL$, ByVal strLocalFilename$) As Boolean 
   Dim lngRet As Long 
    
   lngRet = URLDownloadToFile(0, strURL, strLocalFilename, 0, 0) 
    
   If lngRet = 0 Then DownloadFile = True 
End Function
Gruß Tino
Anzeige
AW: Bild aus bereits geöffneten IE importieren
17.04.2010 12:46:31
Tino
Hallo,
bei Cells fehlt noch der Punkt, mach diesen noch davor.
TopPic = .Cells(lngRow, 1).Top
und 
oPic.Left = .Cells(lngRow, 1).Width / 2
Gruß Tino
AW: Bild aus bereits geöffneten IE importieren
17.04.2010 17:16:15
Nepumuk
Hallo ihr zwei,
wenn die Webseite geöffnet wird, ist das Bild schon gespeichert. Es muss nur in den temporären Internetfiles gesucht werden.
Option Explicit

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
    ByVal hwndOwner As Long, _
    ByVal nFolder As Long, _
    ByRef pidl As ITEMIDLIST) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
    ByVal hFindFile As Long) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long

Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Const R_TEMP_INTERNET = &H20
Private Const NOERROR = 0

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Private Type ITEMID
    cb As Long
    abID As Byte
End Type

Private Type ITEMIDLIST
    mkid As ITEMID
End Type

Private strFile As String
Private blnFound As Boolean

Public Sub Start()
    Dim strPath As String
    strPath = GetPath(R_TEMP_INTERNET) & "\"
    Call FindFiles(strPath, "*.jpg") 'hier den Namen des Bides angeben
    If Not blnFound Then
        MsgBox "Keine Datei gefunden.", 48, "Hinweis"
    Else
        ActiveSheet.Pictures.Insert strFile
    End If
End Sub

Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim udtWFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    Dim strDirName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", udtWFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath, strSearch
        Do
            If blnFound Then Exit Do
            If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = Left$(udtWFD.cFileName, _
                    InStr(udtWFD.cFileName & vbNullChar, vbNullChar) - 1)
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles strFolderPath & strDirName, strSearch
            End If
        Loop While FindNextFile(lngSearch, udtWFD)
        Call FindClose(lngSearch)
    End If
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
    Dim udtWFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    Dim strFileName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & strSearch, udtWFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
                FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = Left$(udtWFD.cFileName, _
                    InStr(udtWFD.cFileName & vbNullChar, vbNullChar) - 1)
                blnFound = True
                strFile = strFolderPath & strFileName
                Exit Do
            End If
        Loop While FindNextFile(lngSearch, udtWFD)
        Call FindClose(lngSearch)
    End If
End Sub

Private Function GetPath(lngId As Long) As String
    Dim lngResult As Long
    Dim strBuffer As String
    Dim udtIdl As ITEMIDLIST
    lngResult = SHGetSpecialFolderLocation(Application.hWnd, lngId, udtIdl)
    If lngResult = NOERROR Then
        strBuffer = Space$(512)
        lngResult = SHGetPathFromIDList(ByVal udtIdl.mkid.cb, ByVal strBuffer)
        If lngResult Then
            GetPath = Trim$(strBuffer)
            GetPath = Left$(GetPath, Len(GetPath) - 1)
        End If
    End If
End Function

Gruß
Nepumuk
Anzeige
AW: bruchsichere Thermosflaschen?
17.04.2010 21:18:04
Nepumuk
Hallo Tino,
wenn der Name des Bildes nur unzureichend bekannt ist, muss die Abfrage beim Dateinamen etwas modifiziert werden. FindFiles arbeitet ähnlich wie Dir mit Wildcards
Call FindFiles(strPath, "*Kerze*.jpg")
Gruß
Nepumuk
etwas einfacher...
17.04.2010 17:09:07
Tino
Hallo,
so geht es auch.
kommt als Code in Modul1 
Option Explicit 
 
Sub test() 
Dim appIE As InternetExplorer, oImage As Object 
Dim ArBilderName 
Dim lngRow&, nCount%, TopPic As Double 
Dim Ziel$ 
Dim oPic As Picture 
Dim booNotIsOben As Boolean 
 
Ziel = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") 
Ziel = Ziel & "tmpImage" 
 
ArBilderName = Array("*.gif", "*.jpg") 
 
Const Url As String = "http://www.google.de/images?hl=de&source=imghp&q=Kerze&gbv=2&aq=f&aqi=g10&aql=&oq=&gs_rfai=" 
 
Set appIE = Find_IE(Url) 
If appIE Is Nothing Then 
    Set appIE = CreateObject("InternetExplorer.application") 
    appIE.Navigate Url 
    booNotIsOben = True 
End If 
 
While Not appIE.ReadyState = 4 
    DoEvents 
Wend 
 
With Sheets("Tabelle1") 
    .Pictures.Delete 
    lngRow = 2 
    .Range("A2", .Cells(.Rows.Count, 1)).Clear 
    TopPic = .Cells(lngRow, 1).Top 
    On Error Resume Next 
    For Each oImage In appIE.Document.images 
        For nCount = Lbound(ArBilderName) To Ubound(ArBilderName) 
            If oImage.href Like ArBilderName(nCount) Then 
                Set oPic = .Pictures.Insert(oImage.href) 
                If Not oPic Is Nothing Then 
                    oPic.Top = TopPic 
                    oPic.Left = .Cells(lngRow, 1).Width / 2 
                    TopPic = oPic.Top + oPic.Height + 10 
                    .Hyperlinks.Add oPic.ShapeRange.Item(1), oImage.href 
                End If 
                Set oPic = Nothing 
            End If 
        Next nCount 
    Next oImage 
End With 
 
If booNotIsOben Then appIE.Quit 
Set appIE = Nothing 
End Sub
kommt als Code in Modul2 
Option Explicit 
 
Function Find_IE(ByVal strAdresse$) As Object 
Dim objShell As Object, oApp As Object 
Dim strTmpAdresse$ 
Set objShell = CreateObject("Shell.Application") 
   
If Right$(strAdresse, 1) = "/" Then 
    strTmpAdresse = Left$(strAdresse, Len(strAdresse) - 1) 
Else 
    strTmpAdresse = strAdresse & "/" 
End If 
   
For Each oApp In objShell.Windows 
  If InStr(UCase(oApp.FullName), "IEXPLORE") > 0 Then 
    If oApp.Document.Location = strAdresse$ Or oApp.Document.Location = strTmpAdresse$ Then 
      Set Find_IE = oApp 
      Exit For 
    End If 
  End If 
Next 
Set objShell = Nothing 
End Function
Gruß Tino
Anzeige
ohne Verweis auf Internetexplorer ;-) ...
17.04.2010 17:11:30
Tino
Hallo,
zum Testen hatte ich noch den Verweis auf Internetexplorer gesetzt.
kommt als Code in Modul1 
Option Explicit 
 
Sub test() 
Dim appIE As Object, oImage As Object 
Dim ArBilderName 
Dim lngRow&, nCount%, TopPic As Double 
Dim Ziel$ 
Dim oPic As Picture 
Dim booNotIsOben As Boolean 
 
Ziel = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") 
Ziel = Ziel & "tmpImage" 
 
ArBilderName = Array("*.gif", "*.jpg") 
 
Const Url As String = "http://www.google.de/images?hl=de&source=imghp&q=Kerze&gbv=2&aq=f&aqi=g10&aql=&oq=&gs_rfai=" 
 
Set appIE = Find_IE(Url) 
If appIE Is Nothing Then 
    Set appIE = CreateObject("InternetExplorer.application") 
    appIE.Navigate Url 
    booNotIsOben = True 
End If 
 
While Not appIE.ReadyState = 4 
    DoEvents 
Wend 
 
With Sheets("Tabelle1") 
    .Pictures.Delete 
    lngRow = 2 
    .Range("A2", .Cells(.Rows.Count, 1)).Clear 
    TopPic = .Cells(lngRow, 1).Top 
    On Error Resume Next 
    For Each oImage In appIE.Document.images 
        For nCount = Lbound(ArBilderName) To Ubound(ArBilderName) 
            If oImage.href Like ArBilderName(nCount) Then 
                Set oPic = .Pictures.Insert(oImage.href) 
                If Not oPic Is Nothing Then 
                    oPic.Top = TopPic 
                    oPic.Left = .Cells(lngRow, 1).Width / 2 
                    TopPic = oPic.Top + oPic.Height + 10 
                    .Hyperlinks.Add oPic.ShapeRange.Item(1), oImage.href 
                End If 
                Set oPic = Nothing 
            End If 
        Next nCount 
    Next oImage 
End With 
 
If booNotIsOben Then appIE.Quit 
Set appIE = Nothing 
End Sub
kommt als Code in Modul2 
Option Explicit 
 
Function Find_IE(ByVal strAdresse$) As Object 
Dim objShell As Object, oApp As Object 
Dim strTmpAdresse$ 
Set objShell = CreateObject("Shell.Application") 
   
If Right$(strAdresse, 1) = "/" Then 
    strTmpAdresse = Left$(strAdresse, Len(strAdresse) - 1) 
Else 
    strTmpAdresse = strAdresse & "/" 
End If 
   
For Each oApp In objShell.Windows 
  If InStr(UCase(oApp.FullName), "IEXPLORE") > 0 Then 
    If oApp.Document.Location = strAdresse$ Or oApp.Document.Location = strTmpAdresse$ Then 
      Set Find_IE = oApp 
      Exit For 
    End If 
  End If 
Next 
Set objShell = Nothing 
End Function
Gruß Tino
Anzeige
AW: etwas einfacher...
17.04.2010 17:52:10
Andy
Hallo Tino,
das hat mir sehr geholfen - wirklich!
Dim appIE as Object funktioniert aber schonmal - immerhin.
Nur rutscht er bei mir immer in die CreateObject Methode rein da er wohl bei 
Set appIE = Find_IE(Url)
die bereits geöffnete Seite nicht findet.
Aber den Rest bekomm ich auch noch irgendwie zusammengebastelt.
Vielen Dank Dir Tino, bist der Wahnsinn! :-)
Anzeige

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige