Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 58324 Skopiuj do schowka Screen z URL do Arkusza
Autor Wiadomość
euzebiusz
Forumowicz


Posty: 24
Wysłany: 14-08-2017, 14:37   Screen z URL do Arkusza

Witam,

Mam taki problem.
Szukam kodu na to by na podstawie URL z komórki, excel otwierał stronę, zrobił print screen i wrzucił to do arkusza (tego samego gdzie jest URL).

Macie jakieś pomysły jak to zrobić?
ID posta: 327824 Skopiuj do schowka
 
 
kanon
Starszy Forumowicz


Pomógł: 2 razy
Posty: 32
Wysłany: 14-08-2017, 15:18   

tutaj da się nagrać makro, właśnie próbowałem :)
ID posta: 327825 Skopiuj do schowka
 
 
euzebiusz
Forumowicz


Posty: 24
Wysłany: 16-08-2017, 08:38   

witam,

Jest problem, excel nie robi wtedy screena, tylko wkleja obraz ze schowka.

Później jest błąd że nie ma obrazu. Więc nie udaje się nagrać tego.
ID posta: 327862 Skopiuj do schowka
 
 
euzebiusz
Forumowicz


Posty: 24
Wysłany: 16-08-2017, 09:34   

Kod:
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private Const VK_SNAPSHOT As Byte = 44

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

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Const SW_SHOWMAXIMIZED = 3
Private Const VK_LCONTROL As Long = &HA2
Private Const VK_V = &H56
Private Const KEYEVENTF_KEYUP = &H2

Sub Sample()
    Dim IE As Object
    Dim hwnd As Long, IECaption As String

    Set IE = CreateObject("InternetExplorer.Application")

    IE.Visible = True

    IE.Navigate "www.Google.com"

    Sleep 5000

    '~~> Get the caption of IE
    IECaption = "Google - Internet Explorer"

    '~~> Get handle of IE
    hwnd = FindWindow(vbNullString, IECaption)

    If hwnd = 0 Then
        MsgBox "IE Window Not found!"
        Exit Sub
    Else
        '~~> Maximize IE
        ShowWindow hwnd, SW_SHOWMAXIMIZED
    End If
Sleep 3000
    DoEvents

    '~~> Take a snapshot
    Call keybd_event(VK_SNAPSHOT, 0, 0, 0)

    '~~> Start Word


    Set wordobj = CreateObject("Word.Application")

   Set objDoc = wordobj.Documents.Add

   wordobj.Visible = True

   Set objSelection = wordobj.Selection

   'Paste into Word
   objSelection.Paste

End Sub


Udało mi się znaleźć na necie coś takiego.
Natomiast kod działa na podstawie URL w kodzie, a zależałoby mi na tym żeby to robił z komórki z arkusza, oraz z tym kodem wkleja to do nowego dokumentu word, a zależałoby mi na tym, żeby wklejał do tego samego arkusza.

Jakieś pomysły?
ID posta: 327866 Skopiuj do schowka
 
 
euzebiusz
Forumowicz


Posty: 24
Wysłany: 05-09-2017, 14:01   

Ludziska,

to co udało mi się przygotować

Kod:
Sub Makro2()
'
' Makro2 Makro
'

'
    Range("AB13").Select
    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
   
    Application.Wait (Now + TimeValue("00:00:10"))
   
    Application.SendKeys "(%{1068})"
   
DoEvents

End Sub


Natomiast pytanie ja zrobić, żeby później ten screen został wklejony w jakąś komórkę.
Próbowałem
Kod:
Range("E5").Select
    ActiveSheet.Paste


Ale nie działa po wykonaniu tego polecenia przez VBA.

Jakiś pomysł?
ID posta: 329080 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3091 razy
Posty: 10240
Wysłany: 06-09-2017, 23:57   

W nagrodę za upór i chęć samodzielnego rozwiązania problemu :-)
Kod:
Option Explicit

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private Const VK_SNAPSHOT As Byte = 44

Enum READYSTATE
    READYSTATE_UNINITIALIZED = 0
    READYSTATE_LOADING = 1
    READYSTATE_LOADED = 2
    READYSTATE_INTERACTIVE = 3
    READYSTATE_COMPLETE = 4
End Enum


Sub a_Sample()
    Dim IE          As Object
    Dim rng         As Range
    Dim strAddress  As String


    Set rng = Range("AB13")

    With rng
        If .Hyperlinks.Count > 0 Then
            strAddress = .Hyperlinks(.Hyperlinks.Count).Address
        End If
    End With

    If Len(Trim(strAddress)) = 0 Then
        MsgBox "Brak adresu!", vbExclamation
        Exit Sub
    End If

    Set IE = CreateObject("InternetExplorer.Application")

    IE.Visible = True
    IE.FullScreen = True

    IE.Navigate strAddress

    Do While (IE.Busy Or IE.READYSTATE <> READYSTATE.READYSTATE_COMPLETE)
        DoEvents
    Loop

    Sleep 2000

    '~~> Take a snapshot
    Call keybd_event(VK_SNAPSHOT, 0, 0, 0)

    IE.Quit
    Set IE = Nothing
    Sleep 1000


    Range("E5").Select

    ActiveSheet.Paste
    ActiveCell.Select


End Sub

Artik
ID posta: 329214 Skopiuj do schowka
 
 
euzebiusz
Forumowicz


Posty: 24
Wysłany: 12-09-2017, 13:14   

ijeeeee....

Super, działa świetnie.

Chciałbym jednak zrobić tak, żeby ten kod zrobił to w każdym z arkuszów.
Pobrał link, zrobił screen, wkleił a potem przeszedł do kolejnego arkusza i zrobił to samo.

Dodałem do kodu Sheets(2).Select, i ten kod, później kolejny numer i znów kod, ale niestety pojawił się problem z

Kod:
Enum READYSTATE


Jest to w ogóle możliwe żeby to zrobić?
ID posta: 329524 Skopiuj do schowka
 
 
euzebiusz
Forumowicz


Posty: 24
Wysłany: 12-09-2017, 14:09   

Dobra, ogarnąłem.

Enum pokazywał błąd, bo były dwa takie same wpisy, bo drugie marko było takie samo.

I wystarczyło z kolejnych arkuszy wyrzucić
Kod:
 Dim IE          As Object
    Dim rng         As Range
    Dim strAddress  As String


Działą super!!

Można zamknać temat wyczerpany
ID posta: 329535 Skopiuj do schowka
 
 
euzebiusz
Forumowicz


Posty: 24
Wysłany: 19-02-2021, 15:29   

witam,
Po aktualizacji office pojawił się problem kompilacji.

Dokładny opis błędu.

Compile error:
The code is this project must be updated for use on 64-bit systems.
Plese review and update Declare statements and then merk them with the PtrSafe attribute.

Poniższe pojawiło się na czerwono.

Kod:

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)



Ktoś jest w stanie w tym pomóc?
ID posta: 400699 Skopiuj do schowka
 
 
wczesny 
Stały bywalec Excelforum


Wersja: Win Office 2016
Pomógł: 31 razy
Posty: 269
Wysłany: 19-02-2021, 15:39   

Musisz dopisać instrukcje warunkowe i chyba zmienić Long na LongPtr:
Kod:

#If VBA7 Then
Declare PtrSafe Sub...
#Else
Declare Sub...
#EndIf
  
ID posta: 400700 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3091 razy
Posty: 10240
Wysłany: 19-02-2021, 15:54   

Spróbuj dotychczasowe deklaracje zamienić na:
Kod:
#If VBA7 And Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
                                                          ByVal bScan As Byte, _
                                                          ByVal dwFlags As Long, _
                                                          ByVal dwExtraInfo As LongPtr)
#Else
        Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
       
        Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
                                                      ByVal bScan As Byte, _
                                                      ByVal dwFlags As Long, _
                                                      ByVal dwExtraInfo As Long)
#End If

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 400703 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe