ACCESSで自動スクショ

-
最近、業務自動化を研究していてその過程で
Webのスクショ取る業務があってそれ自動化できないかと
思ってACCESS/VBAでやってみました。
IEしか対応していませんが・・・・・

IEShotという全画面キャプチャ取得できるコードがあり
有効活用させていただきました。ありがとうございます。

下記の構造でテーブルの準備が必要です
seqNo
targetURL
targetSheetName
startCol
endCol
statRow
endRow
targetComent

エラーハンドリングも適当です。ご使用は自己責任で
お願いします。

Option Compare Database
'Sleep関数用
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'Sleep関数用
'キャプチャ用
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'画面アクティブ制御
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindowAsync Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
'取得対象用構造体
Type RetVal
    SiteUrl As String
    ExcelsheetName As String
    ExcelComent As String
    ExcelStartCol As String
    ExcelEndCol As String
    ExcelStartRow As Long
    ExcelEndRow As Long
End Type

'//*******************************************************************
'//
'// テーブルからURLを取得しIEを開きキャプチャを取得しEXCELに貼付
'//
'//*******************************************************************
Sub AutoCapmain()

    Dim targetObject As RetVal
    Dim objIE As InternetExplorer
    Dim targetCnt As Long
    
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = True
    
    'テーブルを読込んでURLとEXCELシート名を取得する
    Dim rs As New ADODB.Recordset
    rs.Open "select * from t_TargetCap order by seqNo", CurrentProject.Connection
    targetCnt = DCount("*", "t_TargetCap")

    'EXCEL起動
    Dim xlApp   As Excel.Application
    Dim xlbook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim nextxlSheet As Excel.Worksheet
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlbook = xlApp.Workbooks.Add
    Dim i As Long
    Dim CngSheetName As String
    Dim chckVal As Boolean
    
    Do Until rs.EOF
        targetObject = getTarget(rs)
        Call ieNavi(objIE, targetObject.SiteUrl)
        Call ieCheck(objIE)
        'IEの画面キャプチャ取得
        Call getCapture(objIE)
        i = xlbook.Worksheets.Count
        
        'シート判別
        Set xlSheet = xlbook.Worksheets(i)
        If targetObject.ExcelsheetName <> "" Then
            CngSheetName = targetObject.ExcelsheetName
        Else
            CngSheetName = xlSheet.Name
        End If
        chckVal = searchSheetName(xlbook, targetObject.ExcelsheetName)
        
        If chckVal = True Then
            Set xlSheet = xlbook.Worksheets(CngSheetName)
        '最終レコードでシート名が同一でない場合はシート名変更のみ
        ElseIf i = targetCnt And chckVal = False Then
            xlSheet.Name = CngSheetName
        ElseIf i <> targetCnt And chckVal = False Then
        'シートを追加
            xlSheet.Name = CngSheetName
            Set nextxlSheet = xlbook.Worksheets.Add(after:=xlbook.Worksheets(i))
            Set xlSheet = xlbook.Worksheets(CngSheetName)
            i = i + 1
        Else
            MsgBox ("シート設定関連でエラー発生")
        End If
            
        '画面貼付
        With targetObject
            Call runExcel(xlSheet, .ExcelStartCol, .ExcelEndCol, .ExcelStartRow, .ExcelEndRow, .ExcelComent)
        End With
        rs.MoveNext
        xlApp.CutCopyMode = False
    Loop
    ' 終了処理
    xlbook.Worksheets(1).Activate
    rs.Close
    objIE.Quit
    Set objIE = Nothing

End Sub

'//****************************************************
'//
'//  EXCELの操作(指定シートにEXCEL貼付)
'//
'//****************************************************
Function runExcel(xlSheet As Worksheet, startCol As String, _
                    endCol As String, startRow As Long, endRow As Long, eComment As String)
'On Error GoTo Error_Sub

    Dim resizeRFlg As Long
    Dim resizeCFlg As Long
    resizeRFlg = 1
    resizeCFlg = 1
    
    'EXCELをアクティブにする
    xlSheet.Activate
    
    '列の設定(何も入っていない場合の措置)
    Dim sWidth As Long
    If startCol = "" Then
        startCol = "A"
    End If
    Dim sCol As Variant
    Dim eCol As Variant
    If endCol = "" Then
        endCol = "F"
        resizeCFlg = 0
    End If
    
    '行の設定(何も入っていない場合の措置)
    Dim sHeight As Long
    Dim rows As Long
    If startRow < 1 Then
        startRow = 1
    End If
    If endRow < 1 Then
        endRow = 20
        resizeRFlg = 0
    End If
    If endRow - startRow > 0 Then
        rows = endRow - startRow
    Else
        rows = 50
    End If
    
    '高さ、幅指定
    sWidth = xlSheet.Range(startCol & "1" & ":" & endCol & "1").Width
    sHeight = xlSheet.Range("A" & startRow & ":A" & endRow).height
        
    Dim shapeName As String
    'クリップボードのスクリーンショット貼付
    xlSheet.Paste
    
   'TODO:クリップボードの貼付けが失敗したりするので安定しない
    shapeName = selection.ShapeRange.Name
   
   
   'リサイズが必要な場合
    If resizeCFlg = 1 Or resizeRFlg = 1 Then
        With xlSheet.Shapes(shapeName)
            .LockAspectRatio = msoFalse
            .height = sHeight
            .Width = sWidth
            .Top = xlSheet.Range(startCol & startRow).Top
            .Left = xlSheet.Range(startCol & startRow).Left
        End With
    End If
    
   'コメント記載
    If eComment <> "" Then
        Dim comCol As Variant
        comCol = CNumAlp(xlSheet, endCol) + 1
        comCol = CNumAlp(xlSheet, comCol)
        xlSheet.Range(comCol & startRow).Value = eComment
        xlSheet.Range(comCol & "1").select
    End If
    
    Exit Function
    
'Error_Sub:
'    MsgBox ("EXCELとブラウザを終了させて再度ACCESSを実行してください。" & _
'            "頻発する場合はエラー内容をお伝えください。" & _
'            "エラー番号：　" & Err.Number & Chr(13) & Err.Description)
    
End Function
'同一名のシート名称があるか判別
Function searchSheetName(xlsbook As Excel.Workbook, sheetName As String) As Long

    Dim ws As Worksheet
    For Each ws In xlsbook.Sheets
        If ws.Name = sheetName Then
            ' 存在する
            searchSheetName = True
            Exit Function
        End If
    Next
    searchSheetName = False

End Function

'//****************************************************
'//
'//  テーブルから対象のURLとシート名、貼付位置を取得する
'//
'//****************************************************
Function getTarget(rs As ADODB.Recordset) As RetVal
    
    With getTarget
        .SiteUrl = Nz(rs!targetURL)
        .ExcelsheetName = Nz(rs!targetSheetName)
        .ExcelStartCol = Nz(rs!startCol)
        .ExcelEndCol = Nz(rs!endCol)
        .ExcelStartRow = Nz(rs!statRow)
        .ExcelEndRow = Nz(rs!endRow)
        .ExcelComent = Nz(rs!targetComent)
    End With

End Function
'//****************************************************
'//
'//  画面をキャプチャする
'//
'//****************************************************
Sub getCapture(objIE As Object)

    'IEを最前面に表示
    'http://www.macrogirls.net/iesamplecode/vbaie_day2_3.html
    If IsIconic(objIE.hWnd) Then
        ShowWindowAsync objIE.hWnd, &H9
    End If
    SetForegroundWindow (objIE.hWnd)
    
    'IEShotを使用しスクロール対応
    IEShot.IEShot4IE11 objIE, , ""
    
    'Alt+PrintScreen
    'http://www.excel.studio-kazu.jp/kw/20080423200952.html
    'keybd_event &H2C, 1, 0, 0

End Sub
'https://www.vba-ie.net/ie/iefind.html
'指定したURLを表示
Sub ieNavi(objIE As InternetExplorer, _
           urlName As String)
  objIE.navigate urlName
  Call ieCheck(objIE)
End Sub
  '完全にページが表示されるまで待機する
Sub ieCheck(objIE As InternetExplorer)
  Dim timeOut As Date
  timeOut = Now + TimeSerial(0, 0, 20)
  Do While objIE.Busy = True Or objIE.ReadyState <> 4
    DoEvents
    Sleep 1
    If Now > timeOut Then
      objIE.Refresh
      timeOut = Now + TimeSerial(0, 0, 20)
    End If
  Loop

  timeOut = Now + TimeSerial(0, 0, 20)

  Do While objIE.Document.ReadyState <> "complete"
    DoEvents
    Sleep 1
    If Now > timeOut Then
      objIE.Refresh
      timeOut = Now + TimeSerial(0, 0, 20)
    End If
   Loop
End Sub
'https://ateitexe.com/change-alphabet-integer/
'カラムのアルファベットを数値に変換する関数
Function CNumAlp(xlSheet As Worksheet, va As Variant) As Variant
  Dim al As String
 
  If IsNumeric(va) = True Then '数値だったら
    al = xlSheet.cells(1, va).Address(RowAbsolute:=False, ColumnAbsolute:=False) '$無しでAddress取得
    CNumAlp = Left(al, Len(al) - 1)
  Else 'アルファベットだったら
    CNumAlp = xlSheet.Range(va & "1").Column '列番号を取得
  End If
End Function

最初の1回目でエラー出たりでなかったりするんですが
そこの原因がわからない・・・・。
誰か助けていただけると幸いです。

コメント

コメントを投稿

このブログの人気の投稿

GASでGoogleDriveのサブフォルダとファイル一覧を出力する

-
 タイトルのまんまです。 以前、EXCELで似たようなこと をしていたのでGASではどうするのかなぁと思ってやってみました。まぁほとんど丸パクリです。とりあえず、また使うかもしれないので自分用にメモです。しかしGASでGoogleDriveのファイル一覧嘗め回そうとすると3分かかってしまう。数が多いと6分制限に引っかかるのでこれでは使えない。せいぜい100ファイルとか数が少ないところで使う分にはいいけどダイナミックな場合は何回かに分割してやらないと少し厳しいかもしれない。 ◆GAS //設定値取得 const SHEET_URL = SpreadsheetApp.getActiveSpreadsheet().getUrl(); const ss = SpreadsheetApp.openByUrl(SHEET_URL); const SETTING_SHEET = ss.getSheetByName('設定') const TARGET_FOLDER_ID = SETTING_SHEET.getRange('B2').getValue(); const SAVE_FOLDER_ID = SETTING_SHEET.getRange('B3').getValue(); const SAVE_FILE_NAME = SETTING_SHEET.getRange('B4').getValue(); const SAVE_SHEET_NAME = SETTING_SHEET.getRange('B5').getValue(); function writeSheet(values, labels, sheetUrl, sheetname, width) { /* スプレッドシートに書き出し */ try { if (values.length > 0) { // シートを追加する let spreadSheet = SpreadsheetApp.openByUrl(sheetUrl); let sheet = set_sheet(sheetUrl,sheetname); // 1行目だけヘッダ追加 let he...
続きを読む

マクロ経済学(IS-LM分析)

-
イメージ
危うく3日坊主になりそうでした。とりあえず今日は 「IS-LM分析」 です。 テキストでは 簡便4象限法 とかいうのの説明が多いです。なのでさっぱり わけわからん状態ですが、それなりに頑張ってみます。 1: IS曲線 の導出 財市場の均衡を表す。Iは投資を表し、Sは貯蓄を表す。 ・IS曲線導出の材料 I→利子率の関数、S→所得の関数で「I=S」で財市場を表す。 ・ 投資関数 利子率の減少関数、I (投資関数)=I(r)　※rは利子率 ・政府活動の導入 裁量的な拡張的な財政政策はIS曲線をシフトさせる。 IS曲線の右シフト=政府支出の増大や減税等の有効需要を増加させる要因による 2: LM曲線 の導出 利子率の低下が国民所得の増大につながる因果関係を明らかにする目的 ・LM曲線導出の材料 貨幣需要(MD)=L、L=取引的動機+予備的動機(L1)+投機的動機(L2) MD=L1+L2 貨幣供給(Ms)=名目貨幣供給/物価(P) ・LM曲線のシフト 金融緩和策・物価下落：実質貨幣供給(MS)が増大→右(下)へシフト 金融引締策・物価上昇：実質貨幣供給(MS)が減少→左(上)へシフト 独立投資拡大→IS曲線が右にシフト 利子率がr1→r2に下落する。 IS曲線、LM曲線の均衡点がE→Fに移動する。 国民所得がY1→Yfとなって増大する。 3:特殊なLM曲線 ・ 流動性の罠 のLM曲線 金融政策は無効→LM曲線をシフトさせても均衡点Eは変わらない IS曲線を右にシフトさせる拡張的な財政政策を実施すると均衡点が E→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　 ・ 投資の利子率に対する弾力性ゼロ 金融政策は無効→LM曲線を右にシフトさせても国民所得が増えない。 流動性の罠と同じくIS曲線を右にシフトさせる拡張的な財政政策を実施すると 均衡点がE→E´となり国民所得がY1→Y2に増加するので財政政策は有効となる。　　　　　　 4: クラウディング・アウト 政府が市場に介入して公共投資を行うと民間の投資が締出しを受ける ・古典派による財政政策の無効論 政府支出を拡大すると利子率が上昇してしまい。投資が減少する。 政府の支出がクラウディングアウトを引き起こして支...
続きを読む

IEのセキュリティ設定をいじくるバッチ

-
まぁかなり頻出ですがIEでアプリ用に設定しないといけなくて クリックOnlyで処理したかったので色々と調べてみて作ってみた。 ローカルイントラネットの設定いじくるのとActiveX関連をいじくるのと 互換表示設定をいじくっています。 というよりそういう設定しないと動かないアプリの組み方辞めてください。 頼むから・・・。 挙動が微妙に他と違うのでIEとかEdgeには苦しめられます。 @echo off set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap" reg add %REGROOT% /f /v "AutoDetect" /t REG_DWORD /d "0" reg add %REGROOT% /f /v "IntranetName" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "ProxyBypass" /t REG_DWORD /d "1" reg add %REGROOT% /f /v "UNCAsIntranet" /t REG_DWORD /d "1" rem IEのローカルイントラネット設定(*ドメイン指定) set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Ranges\Range1" set REGROOT="HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\対象ドメイン" reg add %REGROOT% /f /v "*" /t REG_DWORD /d "1" rem スクリプトを実行しても安全だとマークされていない activex コントロールの初期化とスクリ...
続きを読む