save html to image

khongtu19bk · 21/12/18

Bài toán của mình là : có một trang web html, phải chụp ảnh lưu thành ảnh dán vào excel.
vì scrollbar phải kéo liên tục, chụp thành nhiều bức ảnh rồi ghép lại cho nên rất mất thời gian.
Mong muốn có thể dùng VBA chụp ảnh.
Mình tìm được đoạn code này trên mạng nhưng chưa điều khiển được thành scrollbar để có thể chụp thành nhiều bức ảnh ghép lại thành cả trang web.
Vậy ai biết xin mách dùm.
code tham khảo.

Mã:

Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As LongLong, ByVal dwExtraInfo As LongPtr)

Private Const VK_SNAPSHOT As Byte = 44

Public Function StoreScreenShotFrom_As(URL_Dest As String, Img_Name As String, Img_Type As String)
    Dim IE As Object, IECaption As String
    Dim aXL As Object, aWB As Object, aSh As Object, aChO As Object, Img_Path As String
    Img_Path = VBA.Environ$("temp") & "\" & Img_Name & "." & Img_Type

    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Visible = True
        .FullScreen = True
        .Navigate URL_Dest

        '''Possibilities to wait until the page is loaded
            'Do While .Busy Or .readyState <> 4
            '    DoEvents
            'Loop
        '''OR
            'Sleep 5000
        '''OR (custom sub below)
            WasteTime 5

        '''Take a snapshot
        Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
        DoEvents
        .Quit
    End With 'IE

    '''Start Excel
    Set aXL = CreateObject("Excel.Application")
    On Error Resume Next
        With aXL
            .WindowState = -4143 'xlNormal
            .Top = 1
            .Left = 1
            .Height = .Document.Body.ScrollRectangle.Height '.UsableHeight
            .Width = .UsableWidth
            .WindowState = -4137  'xlMaximized
    On Error GoTo 0
            Set aWB = .Workbooks.Add
            Set aSh = aWB.Sheets(1)
            Set aChO = aSh.ChartObjects.Add(0, 0, .Width, .Height)
        End With 'aXL

    With aChO
        .Activate
        .Chart.Paste
        With .ShapeRange
            .Line.Visible = msoFalse
            .Fill.Visible = msoFalse
        End With '.ShapeRange
        With .Chart
            .Export Filename:=Img_Path, Filtername:=Img_Type, Interactive:=False
        End With '.Chart
        DoEvents
        .Delete
    End With 'oChrtO
    aWB.Close False
    DoEvents
    aXL.Quit

    StoreScreenShotFrom_As = Img_Path
End Function

Private Sub WasteTime(SecondsToWait As Long)
    Dim TimeLater As Date
    TimeLater = DateAdd("s", SecondsToWait, Now)
    Do While Now < TimeLater
        DoEvents
    Loop
End Sub
Sub test_Prateek_Narendra()
    Dim FilePath As String
    Dim objMsg As Object
    FilePath = StoreScreenShotFrom_As("https://jpnfriend.net", "TestScrenShot", "jpg")

    
End Sub

HeSanbi · 21/12/18

Bạn đọc Code xong có biết nó viết cái gì không vậy. Hướng dẫn xong không biết có sửa code được không
Scroll:

PHP:

Dim height&
height = IE.document.body.ScrollHeight
IE.document.parentWindow.Scroll 0&, 1200&

khongtu19bk · 22/12/18

cám ơn bạn・ phần code của bạn không hoạt động

HeSanbi · 22/12/18

khongtu19bk đã viết:
cám ơn bạn・ phần code của bạn không hoạt động

Bạn đặt nó vào đâu và sửa nó như thế nào. Đưa toàn bộ code đã sửa tôi xem.
Code trên do Microsoft tạo. Chắc ông Microsoft "yếu" không đủ "trình" giúp cho công việc của bạn.
Ở trên tôi chỉ gợi ý thôi. Chứ tôi có hướng dẫn bạn sửa thế nào đâu. Không phải copy vào là được
Tưởng bạn biết VBA và có thể sửa Code chứ

batman1 · 23/12/18

Dùng chụp màn hình thì ảnh không chính xác vì có chứa vd. thanh trạng thái.

Tôi không biết là có thể làm như yêu cầu của bạn không. Hiện tôi hiểu yêu cầu là ...

Ví dụ bạn mở trang web và thấy scrollbar. Bạn nhìn thấy là trang 1 có 4 dòng cuối vd. là: 75, 76, 77, 78. Tôi hiểu là bạn muốn cuộn xuống 1 trang và trang thứ 2 phải có những dòng đầu là 79, 80, 81, 82. Lúc đó khi nối các ảnh sẽ không phải cắt các dòng thừa. Nhưng tôi thử thao tác bằng tay thì cũng không được như yêu cầu đó. Vì khi tôi click vào scrollbar vào chỗ "trống" để cuộn xuống 1 trang thì trang thứ 2 có các dòng đầu tiên là 76, 77, 78, 79

Như thế thậm chí thao tác trực tiếp trong trình duyệt cũng không thể thỏa mãn yêu cầu của bạn.

Nếu bạn chấp nhận được khiếm khuyết nêu ở trên thì xem code dưới. Nó sẽ cuộn trang web đúng như bạn thao tác bằng tay. Ít ra là tôi hi vọng thế

Mã:

Option Explicit

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

Private Const VK_SNAPSHOT As Byte = 44
Private Const VK_NEXT = 34
Private Const KEYEVENTF_KEYUP = 2

Public Sub save_page(IE As Object, ByVal filename As String)
Dim ext As String
    ext = LCase(Mid(filename, InStrRev(filename, ".") + 1))
    keybd_event VK_SNAPSHOT, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    With IE.Document.DocumentElement
        With ActiveSheet.ChartObjects.Add(0, 0, .clientWidth, .clientHeight)
            .Activate
            .Chart.Paste
            .Chart.Export filename, ext
            .Delete
        End With
    End With
End Sub

Public Sub StoreScreenShotFrom_As(URL_Dest As String, Img_Name As String, Img_Type As String)
Dim IE As Object, k As Long, currPos As Long, prevPos As Long
    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Visible = True
        .FullScreen = True
        .Navigate URL_Dest

        '''Possibilities to wait until the page is loaded
        Do While .Busy Or .readyState <> 4
            DoEvents
        Loop
        '''OR
            'Sleep 5000
        '''OR (custom sub below)
        WasteTime 5
        
        With .Document.DocumentElement
            Do
                k = k + 1
                save_page IE, ThisWorkbook.Path & "\" & Img_Name & k & "." & Img_Type
                prevPos = currPos
                keybd_event VK_NEXT, 0, 0, 0
                keybd_event VK_NEXT, 0, KEYEVENTF_KEYUP, 0
                currPos = .scrollTop
            Loop Until currPos = prevPos
        End With
        .Quit
    End With
End Sub

Private Sub WasteTime(SecondsToWait As Long)
    Dim TimeLater As Date
    TimeLater = DateAdd("s", SecondsToWait, Now)
    Do While Now < TimeLater
        DoEvents
    Loop
End Sub

Sub test_Prateek_Narendra()
    StoreScreenShotFrom_As "https://jpnfriend.net", "TestScrenShot", "jpg"
End Sub

khongtu19bk · 23/12/18

batman1 đã viết:
Dùng chụp màn hình thì ảnh không chính xác vì có chứa vd. thanh trạng thái.

Tôi không biết là có thể làm như yêu cầu của bạn không. Hiện tôi hiểu yêu cầu là ...

Ví dụ bạn mở trang web và thấy scrollbar. Bạn nhìn thấy là trang 1 có 4 dòng cuối vd. là: 75, 76, 77, 78. Tôi hiểu là bạn muốn cuộn xuống 1 trang và trang thứ 2 phải có những dòng đầu là 79, 80, 81, 82. Lúc đó khi nối các ảnh sẽ không phải cắt các dòng thừa. Nhưng tôi thử thao tác bằng tay thì cũng không được như yêu cầu đó. Vì khi tôi click vào scrollbar vào chỗ "trống" để cuộn xuống 1 trang thì trang thứ 2 có các dòng đầu tiên là 76, 77, 78, 79

Như thế thậm chí thao tác trực tiếp trong trình duyệt cũng không thể thỏa mãn yêu cầu của bạn.

Nếu bạn chấp nhận được khiếm khuyết nêu ở trên thì xem code dưới. Nó sẽ cuộn trang web đúng như bạn thao tác bằng tay. Ít ra là tôi hi vọng thế

Mã:

Option Explicit Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Const VK_SNAPSHOT As Byte = 44 Private Const VK_NEXT = 34 Private Const KEYEVENTF_KEYUP = 2 Public Sub save_page(IE As Object, ByVal filename As String) Dim ext As String ext = LCase(Mid(filename, InStrRev(filename, ".") + 1)) keybd_event VK_SNAPSHOT, 0, 0, 0 keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0 With IE.Document.DocumentElement With ActiveSheet.ChartObjects.Add(0, 0, .clientWidth, .clientHeight) .Activate .Chart.Paste .Chart.Export filename, ext .Delete End With End With End Sub Public Sub StoreScreenShotFrom_As(URL_Dest As String, Img_Name As String, Img_Type As String) Dim IE As Object, k As Long, currPos As Long, prevPos As Long Set IE = CreateObject("InternetExplorer.Application") With IE .Visible = True .FullScreen = True .Navigate URL_Dest '''Possibilities to wait until the page is loaded Do While .Busy Or .readyState <> 4 DoEvents Loop '''OR 'Sleep 5000 '''OR (custom sub below) WasteTime 5 With .Document.DocumentElement Do k = k + 1 save_page IE, ThisWorkbook.Path & "\" & Img_Name & k & "." & Img_Type prevPos = currPos keybd_event VK_NEXT, 0, 0, 0 keybd_event VK_NEXT, 0, KEYEVENTF_KEYUP, 0 currPos = .scrollTop Loop Until currPos = prevPos End With .Quit End With End Sub Private Sub WasteTime(SecondsToWait As Long) Dim TimeLater As Date TimeLater = DateAdd("s", SecondsToWait, Now) Do While Now < TimeLater DoEvents Loop End Sub Sub test_Prateek_Narendra() StoreScreenShotFrom_As "https://jpnfriend.net", "TestScrenShot", "jpg" End Sub

Cảm ơn bạn, code chạy rất tốt, đã chụp thành nhiều file ảnh để ghép lại thành full screen của web. Tuyệt vời. Sửa một xíu nữa cho các bức ảnh khớp nhau hoàn toàn luôn. Tuyệt vời.

HeSanbi · 23/12/18

khongtu19bk đã viết:
Cảm ơn bạn, code chạy rất tốt, đã chụp thành nhiều file ảnh để ghép lại thành full screen của web. Tuyệt vời. Sửa một xíu nữa cho các bức ảnh khớp nhau hoàn toàn luôn. Tuyệt vời.

Mỗi lần chạy là khởi động lại Internet Explore, bạn có thấy vất vả không

PHP:

'Vào VBA -> Tool -> References.. Chọn Microsoft Internet Control
Public IE_OBJ As Object
Sub IE_Connect()
    Dim AllWindows As New SHDocVw.ShellWindows
    Dim IETab As SHDocVw.InternetExplorer
    Dim IEFound As Boolean
    For Each IETab In AllWindows
      If IETab.Application Like "Internet Explorer" Then
        IEFound = True: Set IE_OBJ = IETab: Exit For
      End If
    Next
    If Not IEFound Then
      Set IE_OBJ = New InternetExplorer
      IE_OBJ.Visible = True
    End If
  End Sub
'Trong Code của bạn thay thế:
Sub YourCode()
    'Nếu có đoạn code Set IE = CreateObject("InternetExplorer.Application") thì Xóa bỏ
    ' Thêm đoạn này vào đầu mỗi Code có sử dụng Object IE
    If IE_OBJ Is Nothing Then IE_Connect
    With IE_OBJ ' Thay cho IE
            '.......................
    End With
End Sub

save html to image

khongtu19bk

Thành viên hoạt động

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

khongtu19bk

Thành viên hoạt động

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

batman1

Thành viên gạo cội

khongtu19bk

Thành viên hoạt động

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian