Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Screen z URL do Arkusza

euzebiusz · Forumowicz Posty: 24

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ć?

kanon · Starszy Forumowicz **Pomógł:** 2 razy Posty: 32

tutaj da się nagrać makro, właśnie próbowałem :)

euzebiusz · Forumowicz Posty: 24

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.

euzebiusz · Forumowicz Posty: 24

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?

euzebiusz · Forumowicz Posty: 24

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ł?

Artik · Wersja: Win Office 365 **Pomógł:** 3091 razy Posty: 10240

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

euzebiusz · Forumowicz Posty: 24

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ć?

euzebiusz · Forumowicz Posty: 24

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

euzebiusz · Forumowicz Posty: 24

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?

wczesny · 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

Artik · Wersja: Win Office 365 **Pomógł:** 3091 razy Posty: 10240

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