GOLD29VBA

Excel

=IFERROR(VLOOKUP($F4,INDEX($B$2:$B$8,MATCH($F4,$B$2:$B$8,0)+I$1-1):$C$8,2,FALSE),"")

=VLOOKUP("*",IF(COUNTIF(C$1:C1,$B$1:$B$9)=0,$B$1:$B$9),1,FALSE)

SQL

Option Explicit


'==========================================================
'データ取得サンプル
'==========================================================
Public Sub GetDataSample()

  Dim temporaryBook As Workbook
  Dim connection    As Object
  Dim recordset     As Object
  Dim sql           As String
  Dim row           As Long

  'ADODBコネクション用Bookを用意
  Set temporaryBook = makeTemporaryBook ': If temporaryBook Is Nothing Then GoTo ERR_END
  GetSheetToBook ThisWorkbook.Worksheets("SQL1").Range("A1"), temporaryBook, "SQL1"
  GetSheetToBook ThisWorkbook.Worksheets("SQL2").Range("A1"), temporaryBook, "SQL2"

  'コネクションを確立
  Set connection = GetADODBConnection(temporaryBook)

  '抽出条件を作成
  sql = "SELECT" _
      & "  B.日本語 " _
      & " FROM [SQL1$] AS A" _
      & "  LEFT OUTER JOIN [SQL2$] AS B" _
      & "   ON A.ID=B.ID AND A.ひらがな=B.ひらがな;" _

  '抽出実行
  If Not getADODBRecordset(connection, sql, recordset) Then GoTo ERR_END

  '抽出結果を出力

'  'フィールド(項目)名を出力
'    For row = 0 To recordset.Fields.Count - 1
'      .Offset(, row).Value = recordset.Fields(row).Name
'    Next row

  '①データを出力
  ThisWorkbook.Worksheets("SQL1").Cells(2, 3).CopyFromRecordset recordset

  '②データを出力
'  row = 2
'  Do Until recordset.EOF
'      ThisWorkbook.Worksheets("SQL1").Cells(row, 3).Value = recordset!日本語
'      recordset.MoveNext
'      row = row + 1
'  Loop


  GoTo FIN

ERR_END:

  MsgBox "エラーですよ"


FIN:

  'レコードセットを閉じる
  CloseRecordSet recordset

  'コネクションを閉じる
  CloseConnection connection

  DeleteBook temporaryBook

End Sub


Function makeTemporaryBook() As Workbook
  Const TEMPORARY_BOOK_NAME = "TEMPORARY_BOOK_FOR_SQL.xlsx"

  Dim newBook As Workbook

  On Error Resume Next
  Set newBook = Application.Workbooks(TEMPORARY_BOOK_NAME)
  On Error GoTo 0

  If Not newBook Is Nothing Then
    DeleteBook newBook
  End If

  Set newBook = Workbooks.Add

  Application.DisplayAlerts = False
  newBook.SaveAs ThisWorkbook.Path & "\" & "TEMPORARY_BOOK_FOR_SQL", xlWorkbookDefault
  Application.DisplayAlerts = True

  Set makeTemporaryBook = newBook

End Function

Function DeleteBook(book As Workbook) As Boolean

  Dim fullname As String
  fullname = book.fullname

  On Error GoTo ERR_END

  book.Close
  Set book = Nothing
  Kill fullname

  On Error GoTo 0

  DeleteBook = True

  GoTo FIN

ERR_END:
  Debug.Print "DeleteBook：削除失敗"
FIN:
End Function


'==========================================================
'GetSheetToBook
'----------------------------------------------------------
'エクセルの表を特定Bookの白紙SheetのA1セルにコピーする
'その際、白紙Sheetに名前を付ける
'==========================================================
Public Sub GetSheetToBook( _
      table_top_left_range_of_src_sheet As Range _
    , destination_book As Workbook _
    , new_sheet_name_as_table_name As String _
)
  Const A1_CELL As String = "A1"
  Dim srcSheet As Worksheet
  Dim tableBottomRightRange As Range
  Dim tableRange As Range
  Dim dstSheet As Worksheet

  With table_top_left_range_of_src_sheet.CurrentRegion
    Set tableBottomRightRange = .Cells(.Rows.Count, .Columns.Count)
  End With

  Set srcSheet = table_top_left_range_of_src_sheet.Parent
  Set tableRange = srcSheet.Range(table_top_left_range_of_src_sheet, tableBottomRightRange)

  With destination_book.Worksheets(1).Range(A1_CELL).SpecialCells(xlCellTypeLastCell)
    If .Address(False, False) = A1_CELL And .Value = Empty Then
      Set dstSheet = destination_book.Worksheets(1)
    Else
      With destination_book
        Set dstSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
      End With
    End If
  End With

  dstSheet.Name = new_sheet_name_as_table_name
  tableRange.Copy
  With dstSheet.Range(A1_CELL)
    .PasteSpecial xlPasteFormats
    .PasteSpecial xlPasteValues
  End With

  Application.DisplayAlerts = False
  destination_book.Save
  Application.DisplayAlerts = True

End Sub




'==========================================================
'GetADODBConnection
'==========================================================
Public Function GetADODBConnection(data_source_book As Workbook) As Object

  Dim ADODBConnection As Object
  Dim connectionString As String

  Set ADODBConnection = CreateObject("ADODB.Connection")

  connectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                   & "Data Source=" & data_source_book.fullname & ";" _
                   & "Extended Properties=""Excel 8.0;" _
                   & "HDR=Yes"";"
  ADODBConnection.Open connectionString

  Set GetADODBConnection = ADODBConnection

End Function

'==========================================================
'GetRecordset
'==========================================================
Public Function getADODBRecordset( _
                        ByRef connection As Object, _
                        ByVal SQL_string As String, _
                        ByRef record_set As Object _
                        ) As Boolean
  Const adOpenDynamic       As Long = 2
  Const adLockOptimistic    As Long = 3

  On Error GoTo ERR_END

  Set record_set = CreateObject("ADODB.Recordset")

  record_set.Open SQL_string, connection, adOpenDynamic, adLockOptimistic

  getADODBRecordset = True

  GoTo FIN

ERR_END:

  MsgBox "getRecordsetにてエラー"

FIN:

End Function


'==========================================================
'コネクション破棄
'==========================================================
Public Sub CloseConnection(objCN As Object)

  Const adStateClosed = 0

  If objCN Is Nothing Then Exit Sub

  If objCN.State <> adStateClosed Then

    objCN.Close

  End If

  Set objCN = Nothing

End Sub

'==========================================================
'レコードセット破棄
'==========================================================
Public Sub CloseRecordSet(objRS As Object)

  Const adStateClosed = 0

  If objRS Is Nothing Then Exit Sub

  If objRS.State <> adStateClosed Then

    objRS.Close

  End If

  Set objRS = Nothing

End Sub

ダウンロード

'======
Sub testGetIEObject()
Dim ie As Object
Set ie = GetIEObject("https://photos.google.com/u/1/photo/AF1QipNlu2ACuq8nktSQuBWFIEjzl9oh2DU-BYCIEKJy")
ファイルダウンロードSample ie
End Sub

'=====================================================----

'以下の情報を元に作成
'https://www.ka-net.org/blog/?p=4855

Public Sub ファイルダウンロードSample(ie As Object)
  With ie
    DownloadFileNbOrDlg .hwnd, "C:\Users\Tom\Documents\自作\Excel遊びテスト3"
  End With
End Sub


Private Sub DownloadFileNbOrDlg(ByVal hIE As Long, ByVal SaveFilePath As String)
'通知バー/Internet Explorerダイアログを操作してファイルをダウンロード
'※ UIAutomationClient(%SYSTEMROOT%\system32\UIAutomationCore.dll)要参照
'
' - hIE:InternetExplorerのハンドル
' - SaveFilePath:ファイルのダウンロード先
'
'http://okwave.jp/qa/q8121989.html
'http://okwave.jp/qa/q8320348.html
'https://gist.github.com/kumatti1/7957796 参考

  Dim uiAuto As CUIAutomation
  Dim elmIE As IUIAutomationElement
  Dim elmNotificationBar As IUIAutomationElement
  Dim elmSaveSplitButton As IUIAutomationElement
  Dim elmSaveDropDownButton As IUIAutomationElement
  Dim elmSaveMenu As IUIAutomationElement
  Dim elmSaveMenuItem As IUIAutomationElement
  Dim elmIEDialog As IUIAutomationElement
  Dim elmSaveAsButton As IUIAutomationElement
  Dim elmSaveAsWindow As IUIAutomationElement
  Dim elmFileNameEdit As IUIAutomationElement
  Dim elmSaveButton As IUIAutomationElement
  Dim elmNotificationText As IUIAutomationElement
  Dim elmCloseButton As IUIAutomationElement
  Dim iptn As IUIAutomationInvokePattern
  Dim vptn As IUIAutomationValuePattern
  Const ROLE_SYSTEM_BUTTONDROPDOWN = &H38&

  Set uiAuto = New CUIAutomation
  Set elmIE = uiAuto.ElementFromHandle(ByVal hIE)

  'ファイルを事前に削除
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(SaveFilePath) Then .DeleteFile SaveFilePath, True
  End With

  Do
    '[通知バー]取得
    Set elmNotificationBar = _
      GetElement(uiAuto, _
                 elmIE, _
                 UIA_AutomationIdPropertyId, _
                 "IENotificationBar", _
                 UIA_ToolBarControlTypeId)

    '[Internet Explorer]ダイアログ((ファイル名) で行う操作を選んでください)取得
    Set elmIEDialog = _
      GetElement(uiAuto, _
                 elmIE, _
                 UIA_NamePropertyId, _
                 "Internet Explorer", _
                 UIA_WindowControlTypeId)
    DoEvents
  Loop Until (Not elmNotificationBar Is Nothing) Or _
             (Not elmIEDialog Is Nothing)

  '***** 通知バー操作ここから *****
  If Not elmNotificationBar Is Nothing Then
    '[保存]スプリットボタン取得
    Set elmSaveSplitButton = _
      GetElement(uiAuto, _
                 elmNotificationBar, _
                 UIA_NamePropertyId, _
                 "保存", _
                 UIA_SplitButtonControlTypeId)
    If elmSaveSplitButton Is Nothing Then GoTo Fin

    '[保存]ドロップダウン取得
    Set elmSaveDropDownButton = _
      GetElement(uiAuto, _
                 elmNotificationBar, _
                 UIA_LegacyIAccessibleRolePropertyId, _
                 ROLE_SYSTEM_BUTTONDROPDOWN, _
                 UIA_SplitButtonControlTypeId)
    If elmSaveDropDownButton Is Nothing Then GoTo Fin

    '[保存]ドロップダウン押下 -> [名前を付けて保存(A)]ボタン押下
    Set iptn = elmSaveDropDownButton.GetCurrentPattern(UIA_InvokePatternId)
    Do
      iptn.Invoke
      Sleep 300
      Set elmSaveMenu = _
        GetElement(uiAuto, _
                   uiAuto.GetRootElement, _
                   UIA_ClassNamePropertyId, _
                   "#32768", _
                   UIA_MenuControlTypeId)
      DoEvents
    Loop While elmSaveMenu Is Nothing
    Set elmSaveMenuItem = _
      GetElement(uiAuto, _
                 elmSaveMenu, _
                 UIA_NamePropertyId, _
                 "名前を付けて保存(A)", _
                 UIA_MenuItemControlTypeId)
    If elmSaveMenuItem Is Nothing Then GoTo Fin
    Set iptn = elmSaveMenuItem.GetCurrentPattern(UIA_InvokePatternId)
    iptn.Invoke
  End If
  '***** 通知バー操作ここまで *****

  '***** Internet Explorerダイアログ操作ここから *****
  If Not elmIEDialog Is Nothing Then
    Set elmSaveAsButton = _
      GetElement(uiAuto, _
                 elmIEDialog, _
                 UIA_NamePropertyId, _
                 "名前を付けて保存(A)", _
                 UIA_ButtonControlTypeId)
    If elmSaveAsButton Is Nothing Then GoTo Fin
    Set iptn = elmSaveAsButton.GetCurrentPattern(UIA_InvokePatternId)
    iptn.Invoke
  End If
  '***** Internet Explorerダイアログ操作ここまで *****

  If (elmNotificationBar Is Nothing) And (elmIEDialog Is Nothing) Then GoTo Fin

  '***** 名前を付けて保存操作ここから *****
  Sleep 300
  '[名前を付けて保存]ダイアログ取得
  Do
    Set elmSaveAsWindow = _
      GetElement(uiAuto, _
                 uiAuto.GetRootElement, _
                 UIA_NamePropertyId, _
                 "名前を付けて保存", _
                 UIA_WindowControlTypeId)
    DoEvents
  Loop While elmSaveAsWindow Is Nothing

  '[ファイル名]欄取得 -> ファイルパス入力
  Set elmFileNameEdit = _
    GetElement(uiAuto, _
               elmSaveAsWindow, _
               UIA_NamePropertyId, _
               "ファイル名:", _
               UIA_EditControlTypeId)
  If elmFileNameEdit Is Nothing Then GoTo Fin
  Set vptn = elmFileNameEdit.GetCurrentPattern(UIA_ValuePatternId)
  vptn.SetValue SaveFilePath

  '[保存(S)]ボタン押下
  Set elmSaveButton = _
    GetElement(uiAuto, _
               elmSaveAsWindow, _
               UIA_NamePropertyId, _
               "保存(S)", _
               UIA_ButtonControlTypeId)
  If elmSaveButton Is Nothing Then GoTo Fin
  Set iptn = elmSaveButton.GetCurrentPattern(UIA_InvokePatternId)
  iptn.Invoke
  '***** 名前を付けて保存操作ここまで *****

  '***** ダウンロード完了待ちここから *****
  If elmNotificationBar Is Nothing Then
    '[通知バー]取得
    Do
      Set elmNotificationBar = _
        GetElement(uiAuto, _
                   elmIE, _
                   UIA_AutomationIdPropertyId, _
                   "IENotificationBar", _
                   UIA_ToolBarControlTypeId)
      DoEvents
    Loop While elmNotificationBar Is Nothing
  End If

  '[通知バーのテキスト]取得
  Set elmNotificationText = _
    GetElement(uiAuto, _
               elmNotificationBar, _
               UIA_NamePropertyId, _
               "通知バーのテキスト", _
               UIA_TextControlTypeId)
  If elmNotificationText Is Nothing Then GoTo Fin

  '[閉じる]ボタン取得
  Set elmCloseButton = _
    GetElement(uiAuto, _
               elmNotificationBar, _
               UIA_NamePropertyId, _
               "閉じる", _
               UIA_ButtonControlTypeId)
  If elmCloseButton Is Nothing Then GoTo Fin

  Do
    DoEvents
  Loop Until InStr( _
    elmNotificationText.GetCurrentPropertyValue(UIA_ValueValuePropertyId), _
    "ダウンロードが完了しました") > 0

  '[閉じる]ボタン押下
  Set iptn = elmCloseButton.GetCurrentPattern(UIA_InvokePatternId)
  iptn.Invoke
  '***** ダウンロード完了待ちここまで *****

  Exit Sub
Fin:
  MsgBox "処理が失敗しました。", vbCritical + vbSystemModal
End Sub

Private Function GetElement(ByVal uiAuto As CUIAutomation, _
                            ByVal elmParent As IUIAutomationElement, _
                            ByVal propertyId As Long, _
                            ByVal propertyValue As Variant, _
                            Optional ByVal ctrlType As Long = 0) As IUIAutomationElement
  Dim cndFirst As IUIAutomationCondition
  Dim cndSecond As IUIAutomationCondition

  Set cndFirst = uiAuto.CreatePropertyCondition( _
                   propertyId, _
                   propertyValue _
                 )
  If ctrlType <> 0 Then
    Set cndSecond = uiAuto.CreatePropertyCondition( _
                      UIA_ControlTypePropertyId, _
                      ctrlType _
                    )
    Set cndFirst = uiAuto.CreateAndCondition( _
                     cndFirst, _
                     cndSecond _
                   )
  End If
  Set GetElement = elmParent.FindFirst(TreeScope_Subtree, cndFirst)
End Function

IE関連

'********************************************************************************
' 関数名：GetIEObject
' 概要　：指定されたURLを開いているInternetExplorerのインスタンスを返します
' 引数　：[url]...URL
' 戻り値：InternetExplorerのインスタンス
'********************************************************************************
Public Function GetIEObject(ByVal url As String) As Object
    '戻り値を初期化します
    Set GetIEObject = Nothing

    'Shell.ApplicationのCOMをインスタンス化します
    Dim sh As Object
    Set sh = CreateObject("Shell.Application")

    '起動中のWindowを1つずつ調べます
    Dim w As Object
    For Each w In sh.Windows
        'InternetExplorerであれば
        If InStr(w.Name, "Internet Explorer") > 0 Then
            'かつ、指定されたURLを起動中であれば
            If (w.LocationURL = url) Then
                'そのインスタンスを戻り値となる変数にセットし、ループを抜けます
                Set GetIEObject = w
                Exit For
            End If
        End If
    Next
End Function


Option Explicit

'----------------------------------------
' Win32 API定義
'----------------------------------------
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'Internet ExplorerのCOMをインスタンス化します
Dim ie As New InternetExplorer

Sub ログインページを開く()

    'サンプルHTMLを開いているInternet Explorerのインスタンスを取得します
    Set ie = GetIEObject("https://www.pairs.lv/")
    If (ie.LocationURL = "") Then
        ie.navigate "https://www.pairs.lv/"
        Exit Sub
    End If

    ie.Visible = Trsue

    Dim ancObj As HTMLAnchorElement
    For Each ancObj In ie.document.getElementsByClassName("login-facebook-button direct_btn")
        '当該ハイパーリンクを見つけたらクリックします
        ancObj.Click
        Exit For
    Next



End Sub
Sub FaceBookログインページのieセット()

    'Shell.ApplicationのCOMをインスタンス化します
    Dim sh As Object
    Set sh = CreateObject("Shell.Application")

    '起動中のWindowを1つずつ調べます
    Dim w As Object
    For Each w In sh.Windows
        'InternetExplorerであれば
        If (TypeOf w Is InternetExplorer) Then
            'かつ、指定のWebページを起動中であれば
            If (0 < InStr(w.LocationURL, "https://www.facebook.com/login")) Then
                'そのインスタンスを変数「ie」にセットし、ループを抜けます
                Set ie = w
                Exit For
            End If
        End If
    Next

    Dim inpObj As HTMLInputElement
    Set inpObj = ie.document.getElementById("email")
    inpObj.Value = ""

    Set inpObj = ie.document.getElementById("pass")
    inpObj.Value = ""

    Set inpObj = ie.document.getElementById("u_0_0")
    inpObj.Click

End Sub


Sub inputTest()

    Const targetURL As String = "https://lms.gacco.org/courses/course-v1:gacco+ga031+2019_10/courseware/572b7833ed5b4ba7983e5383fa5e4c8c/fc1b5aecd0304871a36f99f2aa73d7b6/"

    Dim ie As Object
    Set ie = GetIEObject(targetURL)
    If (ie.LocationURL = "") Then
        ie.Navigate targetURL
        Exit Sub
    End If

    ie.Visible = True

    Dim formElement As Object
    Set formElement = ie.document.getElementsByTagName("form")(0)

    Dim formElemChildren As Object
    Set formElemChildren = GetChildrenByTagname(formElement, "input select textarea")

    Dim element As Object
    For Each element In formElemChildren
        Select Case StrConv(element.tagName, vbLowerCase)
            Case "input"
                Select Case StrConv(element.Type, vbLowerCase)
                    Case "hidden"
                    Case "radio"
                        CheckByParentInnerText element, "01", include:=True
                    Case "text"
                        element.Value = "test"
                    Case "checkbox"
                        CheckByParentInnerText element, "02", include:=True
                    Case "submit"
                    Case Else
                End Select
            Case "select"
                SelectOptionByValueOrByInnerText element, "東京都"
            Case "textarea"
                element.Value = "test" & vbCrLf & "test"
            Case Else
        End Select
    Next


End Sub

Function GetChildrenByTagname(parentElement As Object, tagNamesSeparetedSpace As String, Optional ByRef elementCollection As Collection) As Object
    If elementCollection Is Nothing Then
        Set elementCollection = New Collection
    End If


    Dim tagNameArray As Variant, tagName As Variant
    tagNameArray = Split(tagNamesSeparetedSpace, " ")

    Dim element As Object, i As Long
    For Each element In parentElement.Children

        GetChildrenByTagname element, tagNamesSeparetedSpace, elementCollection

        For i = LBound(tagNameArray) To UBound(tagNameArray)
            If StrConv(element.tagName, vbLowerCase) = tagNameArray(i) Then
                elementCollection.Add element
            End If
        Next
    Next

    Set GetChildrenByTagname = elementCollection
End Function



Sub SelectOptionByValueOrByInnerText(selectElement As Object, valueOrInnerText As String)


    Dim optionEleCollec As Collection
    Set optionEleCollec = GetChildrenByTagname(selectElement, "option")

    Dim element As Object
    For Each element In optionEleCollec

        If element.Value = valueOrInnerText _
        Or element.innerText = valueOrInnerText Then

            element.Selected = True

        End If

    Next

End Sub


Sub CheckByParentInnerText(inputElement As Object, innerText As String, Optional include As Boolean = False)

    Dim checkFlg As Boolean
    checkFlg = False

    If include = True Then
        If InStr(inputElement.parentElement.innerText, innerText) > 0 Then
            checkFlg = True
        End If
    Else
        If inputElement.parentElement.innerText = innerText Then
            checkFlg = True
        End If
    End If

    inputElement.Checked = checkFlg
End Sub

タブキーによる選択の移動

Sub testtest()
    Dim ie As Object
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = True
    ie.navigate "about:blank"               'IE開く

    ie.navigate "http://synodos.jp/"    '指定のURLを開く

    'Internet ExplorerがURLを開けずにループし続ける場合を考慮し、制限時間を設けます
    'その前に、読み込み開始時間を記憶します
    Dim st As Date
    st = Now()

    Debug.Print st
    Debug.Print Format(st, "mmdd")

    '完全に開ききるまで待機します
    Do
        '開き終えたらループを抜けます
        If (ie.Busy = False) Then
            Exit Do
        End If

        '10秒経過してもInternet Explorerから処理が返ってこない場合は該当URLの読み込みを中断します
        If (DateAdd("s", 10, st) < Now()) Then
            Debug.Print "10秒以上経過したため、処理を中断します"
            ie.stop
            Exit Sub

        End If

        '1秒間待機します
        Sleep 1000

        '念のためタスクを開放します
        DoEvents
    Loop

    SetForegroundWindow ie.hwnd 'IEをアクティブに
    Application.Wait [Now()+”00:00:02”] '待機


    Dim obj As Object
    For Each obj In ie.document.getElementsByTagName("html") 'IEだとタブのフォーカスが最初はアドレスバーにあるから位置をhtmlに移動
        obj.Focus
        Exit For
    Next
    SendKeys "{TAB}{TAB}{TAB}"

End Sub

アップロードするファイルの選択

'----------------- API宣言部分 -----------------
Private Declare Function FindWindowEx Lib "user32.dll" _
    Alias "FindWindowExA" ( _
    ByVal hWndParent As Long, _
    ByVal hwndChildAfter As Long, _
    ByVal lpszClass As String, _
    ByVal lpszWindow As String) As Long

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

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal Msg As Long, _
        ByVal wParam As Long, ByVal lParam As Any) As Long

'Internet ExplorerのCOMをインスタンス化します
Dim ie As New InternetExplorer

Sub test()

  Dim hInputBox As Long
  Dim hButton As Long
  Dim hWindow As Long

'HWND FindWindow(
'  LPCTSTR lpClassName,  // クラス名
'  LPCTSTR lpWindowName  // ウィンドウ名
');

  hWindow = FindWindow("#32770", "アップロードするファイルの選択") '#32770は「ダイアログ」のクラス名

'HWND FindWindowEx(
'  HWND hwndParent,   // 親ウィンドウのハンドル
'  HWND hwndChildAfter,  // 子ウィンドウのハンドル
'  LPCTSTR lpszClass,   // クラス名
'  LPCTSTR lpszWindow   // ウィンドウ名
');

'入力ボックスについては幾つかのコントロールの入れ子になっているので、
'「ダイアログ」の中にある「ComboBoxEx32」の、更に中にある「ComboBox」の・・・
'といった様に順番に掘り下げていく必要があります。

'・親ウィンドウのハンドルは先ほど取得したダイアログのハンドルを指定します。
'・子ウィンドウのハンドルは無し。
hInputBox = FindWindowEx(hWindow, 0&, "ComboBoxEx32", "")

  hInputBox = FindWindowEx(hInputBox, 0&, "ComboBox", "")

'・入力ボックスのクラス名は「Edit」。ウィンドウ名は無し。
  hInputBox = FindWindowEx(hInputBox, 0&, "Edit", "")

'・ボタンのクラス名は「Button」。ウィンドウ名は「開く(&O)」となります。
  hButton = FindWindowEx(hWindow, 0&, "Button", "開く(&O)")

'ファイルパス入力'
Call SendMessage(hInputBox, &HC, 0, "C:\Users\Tom\Desktop\Excel遊び.xlsm")



'LRESULT SendMessage(
'  HWND hWnd,     // 送信先ウィンドウのハンドル
'  UINT Msg,       // メッセージ
'  WPARAM wParam,  // メッセージの最初のパラメータ
'  LPARAM lParam   // メッセージの 2 番目のパラメータ
');

'ボタン押下'
Call SendMessage(hButton, &H6, 1, 0&)  'ボタンをアクティブにする
Call SendMessage(hButton, &HF5, 0, 0&) 'ボタンをクリックする

End Sub

OutLook関連

Option Explicit

Sub sample()
    Dim outLookAp As Object
    Set outLookAp = CreateObject("Outlook.Application")


    Dim objItem As Object
    Dim objAttachment As Object
    Dim strFile As String
    Dim strPath As String

    strPath = "C:\Users\Tom\Documents\電子書籍\IT\プログラミング・スクリプト\Excel VBAクローリング＆スクレイピング\Sample\3\tmp\tmp" 'ファイルを保存したいフォルダ

    Set objItem = outLookAp.ActiveInspector.CurrentItem '今開いているメールオブジェクトを取得
    For Each objAttachment In objItem.Attachments
        strFile = strPath & "\" & objAttachment.Filename
        objAttachment.SaveAsFile strFile
    Next

End Sub

Sub GetAllMail()
    Dim objOutlook As Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim 受信トレイ As Object
    Dim mailFolder As Object

    Set objOutlook = New Outlook.Application
    Set myNamespace = objOutlook.GetNamespace("MAPI")

    Set 受信トレイ = myNamespace.GetDefaultFolder(olFolderInbox)

    Dim i As Long: i = 1 '出力用カウンタ
    Debug.Print 受信トレイ.Name
    メールを取得し､サブフォルダがあればそのメールも取得 受信トレイ, i

End Sub

Sub メールを取得し､サブフォルダがあればそのメールも取得(フォルダ As Object, ByRef mailCnt As Long)

    Dim i As Long
    If フォルダ.Items.Count > 0 Then
        For i = 1 To フォルダ.Items.Count
            mailCnt = mailCnt + 1
            With ThisWorkbook.Worksheets("Outlook")
                .Cells(mailCnt, 1).Value = フォルダ.Items(i).SentOn
                .Cells(mailCnt, 2).Value = フォルダ.Items(i).Subject
                .Cells(mailCnt, 3).Value = フォルダ.Items(i).Body
            End With
        Next i
    End If
    Dim mailFolder As Object
    For Each mailFolder In フォルダ.Folders
        Debug.Print mailFolder.Name
        メールを取得し､サブフォルダがあればそのメールも取得 mailFolder, i
    Next mailFolder
End Sub

ドラッグ&ドロップ関連

Private Sub ListView1_OLEDragDrop( _
    Data As MSComctlLib.DataObject, _
    Effect As Long, _
    Button As Integer, _
    Shift As Integer, _
    x As Single, _
    y As Single)

    Dim LineText As String
    Dim AllText As String
    Dim i

    If Data.Files.Count > 0 Then
        For i = 1 To Data.Files.Count
            MsgBox Data.Files(i)
        Next i
    End If
End Sub

クリップボード関連

Private Sub クリップボードの中身判定()
    Dim ClipBoard As Variant
    Dim i As Long

    ClipBoard = Application.ClipboardFormats

    If ClipBoard(1) = -1 Then
        MsgBox "クリップボードは空です。", vbExclamation
        Exit Sub
    End If

    For i = 1 To UBound(ClipBoard)
        MsgBox ClipBoard(i)
    Next i
End Sub

Private Sub クリップボードの中を見る()
    Dim CB As New DataObject
    CB.GetFromClipboard
    MsgBox CB.GetFormat(1)
sub
'https://staff.qualias.jp/technology/excel-vba-clipboard/




Public Function 提出期限(ByVal a_day As Date) As Date

    Dim day21later As Date
    day21later = a_day + 21

    Dim calender_array() As Variant
    calender_array = Calender.Range("カレンダー").Value
    Dim bisDayCnt As Long: bisDayCnt = 0
    Dim i As Long
    For i = UBound(calender_array) To LBound(calender_array) Step -1

        If day21later = calender_array(i, 1) Then

            Do
                If calender_array(i, 2) = 0 Then
                    bisDayCnt = bisDayCnt + 1

                    If bisDayCnt >= 2 Then Exit For

                End If

                i = i - 1

            Loop While i >= LBound(calender_array)
            Debug.Print "え！？"

        End If

    Next

    提出期限 = calender_array(i, 1)

End Function

自動実行

Excelマクロ自動実行サンプル
"C:\Program Files (x86)\Microsoft Office\root\Office16\EXCEL.EXE"
C:\Users\Tom\Documents\自作\自動実行\自動実行サンプル.xlsm /e

ピボットテーブル関連

Sub temp()
    Debug.Print Sheet_Table.ListObjects("売上表").Range.Address
    Debug.Print Sheet_Table.Range("売上表").Address
End Sub

Sub Macro1()
    '初期設定
    On Error Resume Next: Application.DisplayAlerts = False
        ThisWorkbook.Sheets("ピボットテーブル").Delete
    On Error GoTo 0: Application.DisplayAlerts = True

    Dim shPivot As Worksheet
    Set shPivot = CodeNameとシート名を指定してシートを作成("Sheet_PivotTable", "ピボットテーブル")

    Dim Lobj売上表 As ListObject
    Set Lobj売上表 = Sheet_Table.ListObjects("売上表")

    With ThisWorkbook.PivotCaches
        Dim pCache As PivotCache
        Set pCache = .Create(SourceType:=xlDatabase, SourceData:=Lobj売上表.Range, Version:=xlPivotTableVersion10)
    End With
    With pCache
        Dim pTable As pivotTable
        Set pTable = .CreatePivotTable(TableDestination:=shPivot.Cells(6, 3), TableName:="ピボットテーブルFrom売上表", DefaultVersion:=xlPivotTableVersion10)
    End With

    ピボットテーブルの行フィールド設定 pTable, Lobj売上表.HeaderRowRange.Cells(, 4).Value
    ピボットテーブルの列フィールド設定 pTable, Lobj売上表.HeaderRowRange.Cells(, 1).Value
    ピボットテーブルのデータフィールド設定 pTable, Lobj売上表.HeaderRowRange.Cells(, 8).Value
End Sub


Sub testChangeCodeName()
ChangeCodeName "sheet_test", "Sheet30"
End Sub
Public Sub ChangeCodeName(newCodeName As String, oldCodeName As String)
    ThisWorkbook.VBProject.VBComponents(oldCodeName).Properties("_CodeName") = newCodeName
End Sub

Sub test新しいシートをCodeNameを指定して追加()
CodeNameとシート名を指定してシートを作成 "Sheet_PivotTable", "ピボットテーブル"
End Sub
Function CodeNameとシート名を指定してシートを作成(newCodeName As String, newName As String) As Worksheet
    Dim newSheet As Worksheet
    With ThisWorkbook
        Set newSheet = .Sheets.Add(After:=.Sheets(.Sheets.Count))  'AddメソッドはAddしたシートを返す
    End With
    ChangeCodeName newCodeName, newSheet.CodeName
    newSheet.Name = newName
    Set CodeNameとシート名を指定してシートを作成 = newSheet
End Function

Sub ピボットテーブルの行フィールド設定(pTable As pivotTable, 項目名 As String)
    With pTable.PivotFields(項目名)
        .Orientation = xlRowField
        .Position = 1
    End With
End Sub
Sub ピボットテーブルの列フィールド設定(pTable As pivotTable, 項目名 As String)
    With pTable.PivotFields(項目名)
        .Orientation = xlColumnField
        .Position = 1
        .AutoGroup
    End With
End Sub
Sub ピボットテーブルのデータフィールド設定(pTable As pivotTable, 項目名 As String)
    With pTable
        .AddDataField .PivotFields(項目名), "合計 / 数量", xlSum
    End With
End Sub
Sub 折れ線グラフ()
    Dim obj As Shape
    Set obj = ActiveSheet.Shapes.AddChart2(227, xlLine)
    With obj.Chart
        .SetSourceData Source:=Sheet_PivotTable.Range("ピボットテーブル!$C$6:$G$21")
    End With
End Sub

配列関連

Sub データ一つ検証() 'セル一つのだとvar配列はエラーになる！
    Dim var配列() As Variant
    var配列 = Sheet_配列.Range("A1").Value
End Sub
Sub データ二つ検証() 'セル二つのだとvar配列はエラーにならない！⇒テーブルデータの場合は敢えてテーブルヘッダの行も入れるべき！
    Dim var配列() As Variant
    With Sheet_配列
        var配列 = .Range(Range("A1"), Range("A2")).Value
    End With
End Sub
Sub 日付列の日付データをdebugPrint()
    Const 日付ラベルセル番地 As String = "A1"
    Const ラベルの分 As Integer = 1
    Dim 日付配列() As Variant
    With Sheet_配列.Range(日付ラベルセル番地)
        If .End(xlDown).Row = .Parent.Rows.Count Then Exit Sub
        日付配列 = .Resize(.End(xlDown).Row - (.Row - ラベルの分), 1).Value
    End With
    Dim i As Long
    For i = LBound(日付配列) + ラベルの分 To UBound(日付配列)
        Debug.Print 日付配列(i, 1)
    Next
End Sub

非表示行削除

Sub 非表示行削除(sh As Worksheet)

    Application.ScreenUpdating = False '画面更新を停止
    Application.EnableEvents = False 'イベント発生を停止

    'Ctrl+Endによる移動
    Dim workRng As Range
    Set workRng = sh.Cells.SpecialCells(xlLastCell)

    '直後の可視セルに移動
    Do
        Set workRng = workRng.Offset(1)
    Loop While workRng.EntireRow.Hidden

    '行非表示セルをdelRows変数に格納
    Dim delRows As Range
    Do
        Set workRng = workRng.Offset(-1)
        If workRng.EntireRow.Hidden Then
            If delRows Is Nothing Then
                Set delRows = workRng
            Else
                Set delRows = Union(delRows, workRng)
            End If
        End If
    Loop Until workRng.Row = 1

    '行非表示セルがあったのなら非表示行を削除
    If Not delRows Is Nothing Then
        delRows.EntireRow.Delete
    End If

    Application.EnableEvents = True 'イベント発生再開
    Application.ScreenUpdating = True '画面更新再開

End Sub
Sub test非表示行削除()
非表示行削除 ActiveSheet
End Sub

日付関連

Function 文字列yyyymmddを日付に変換(str_yyyymmdd As String) As Date
    Dim work_str As String
    work_str = Format(str_yyyymmdd, "####/##/##") 'Format関数の"#"は数字１文字を表す
    If IsDate(work_str) Then
        文字列yyyymmddを日付に変換 = CDate(work_str)
    Else
        Debug.Print "引数不正（引数[" & str_yyyymmdd & "]がyyyymmdd形式でない）"
    End If
End Function
Sub test文字列yyyymmddを日付に変換()
Debug.Print 文字列yyyymmddを日付に変換("19911006")
End Sub

Function 文字列yyyymmddを引数n分前後させる(str_yyyymmdd As String, n As Long)
    Dim work_dt As Date
    work_dt = 文字列yyyymmddを日付に変換(str_yyyymmdd)
    work_dt = DateAdd("d", n, work_dt)
    文字列yyyymmddを引数n分前後させる = Format(work_dt, "yyyymmdd")
End Function
Sub test文字列yyyymmddを引数n分前後させる()
Debug.Print 文字列yyyymmddを引数n分前後させる("19910721", 10000)
End Sub

埋め込みグラフをセルに合わせる

Private Sub Worksheet_Change(ByVal Target As Range) 'セルの値が変更されたとき
    If Intersect(Target, Range("2:3")) Is Nothing Then
        Exit Sub
    Else
        MsgBox "セルの値が変更されました"
    End If
End Sub

Enum idx
    top = 0
    lef
    wid
    hei
End Enum

Sub ShapesFit()
    Dim myRange As Range
    Dim 位置と大きさ_外 As Variant, 位置と大きさ_内 As Variant
    位置と大きさ_外 = 位置と大きさを取得("外")
    位置と大きさ_内 = 位置と大きさを取得("内")

    Dim myShape As Shape
    Set myShape = ActiveSheet.Shapes("サンプルグラフ")
    Dim myChild As Variant
    myShape.Chart.SetSourceData Source:=Range("グラフ!$D$2:$G$3")
    With myShape
        .left = 位置と大きさ_外(idx.lef)
        .width = 位置と大きさ_外(idx.wid)
        .top = 位置と大きさ_外(idx.top)
        .Height = 位置と大きさ_外(idx.hei)
    End With
    With myShape.Chart
       Debug.Print .PlotArea.InsideLeft
       Debug.Print .PlotArea.InsideWidth
       Debug.Print .PlotArea.InsideTop
       Debug.Print .PlotArea.InsideHeight
        .PlotArea.InsideLeft = 位置と大きさ_内(idx.lef) - 位置と大きさ_外(idx.lef) - 4 '4は微調整
        .PlotArea.InsideWidth = 位置と大きさ_内(idx.wid)
        .PlotArea.InsideTop = 位置と大きさ_内(idx.top) - 位置と大きさ_外(idx.top) - 4
        .PlotArea.InsideHeight = 位置と大きさ_内(idx.hei)
       Debug.Print .PlotArea.InsideLeft
       Debug.Print .PlotArea.InsideWidth
       Debug.Print .PlotArea.InsideTop
       Debug.Print .PlotArea.InsideHeight
    End With
End Sub
Function 完全一致検索(検索値 As String) As Range
    Set 完全一致検索 = Cells.Find(What:=検索値, After:=Range("A1"), LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , MatchByte:=False, SearchFormat:=False)
End Function

Function 位置と大きさを取得(内or外 As String) As Variant
    If Not (内or外 = "内" Or 内or外 = "外") Then
        MsgBox "設定エラー"
        Exit Function
    End If
    Dim Ret(4) As Variant

    Dim 左上Rng As Range, 右下Rng As Range
    Set 左上Rng = 完全一致検索("【左上(" & 内or外 & ")】")
    Set 右下Rng = 完全一致検索("【右下(" & 内or外 & ")】")
    Ret(idx.top) = 左上Rng.top
    Ret(idx.lef) = 左上Rng.left
    Ret(idx.wid) = 右下Rng.left + 右下Rng.width - 左上Rng.left
    Ret(idx.hei) = 右下Rng.top + 右下Rng.Height - 左上Rng.top
    位置と大きさを取得 = Ret
End Function

Outlook イベント操作

Microsoft Word Objects

Private Sub Document_Open()
    SetOutlookAppEvent
End Sub

標準モジュール

Module_AppEvent

Option Explicit

Private ObjOutlookAppEvent As New OutlookAppEvent

Public Sub SetOutlookAppEvent()
    Application.Visible = False
    Set ObjOutlookAppEvent = Nothing '2回以上呼び出す場合のため
    Set ObjOutlookAppEvent.App = CreateObject("Outlook.Application")
End Sub

クラスモジュール

OutlookAppEvent

Option Explicit

'-------------
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hWnd As Long, ByVal lpsz0p As String, ByVal lpszFile As String, _
         ByVal lpszParams As String, ByVal lpszDir As String, _
         ByVal FsShowCmd As Long) As Long
'-------------

Public WithEvents App As Outlook.Application
Private ObjWordAppEvent As New WordAppEvent

Const TITLE = "test" ' 自動処理するメールの件名

Private Sub App_NewMailEx(ByVal EntryIDCollection As String)
    Dim arrEntryId() As String, objMail As Object, i As Long
    arrEntryId = Split(EntryIDCollection, ",")
    For i = LBound(arrEntryId) To UBound(arrEntryId)
        Set objMail = App.Session.GetItemFromID(arrEntryId(i))
        If InStr(objMail.Subject, TITLE) > 0 Then
            MsgBox "you got mail !"
            PrintAttachments objMail
        End If
    Next
End Sub

Private Sub App_Quit()
    Dim setTime As Date
    setTime = Now + TimeValue("00:00:05")  '5秒後に実行
    Application.OnTime setTime, "SetOutlookAppEvent"
End Sub

Private Sub App_Startup()
'OutlookAppEventクラスのオブジェクトの中にThisDocumentを扱うWordを格納することで、
'他のWordを起動したときにそのWordもInvisibleになってしまうのを防止することに成功した。
    Set ObjWordAppEvent = Nothing
    Set ObjWordAppEvent.App = GetObject(ThisDocument.FullName).Parent
    ObjWordAppEvent.App.Visible = False
End Sub

Public Sub PrintAttachments(ByVal objMail As MailItem)
MsgBox "PrintAttachments関数を呼び出しました"
    Const ATTACH_PATH = "C:\Users\Tom\Desktop\"   ' 添付ファイルを保存するフォルダを指定

    Dim objAttach As Attachment
    Dim strFileName As String
MsgBox "添付ファイル数：" & objMail.Attachments.Count
    If objMail.Attachments.Count > 0 Then
        For Each objAttach In objMail.Attachments
            ' 添付ファイルを指定フォルダに保存
            strFileName = ATTACH_PATH & objAttach.FileName
MsgBox strFileName & "を保存します"
            objAttach.SaveAsFile strFileName
            ' 保存したファイルを印刷する
'            Call ShellExecute(0, "print", strFileName, 0, ATTACH_PATH, 0)
        Next
    Else
    End If

End Sub

WordAppEventWordAppEvent

Option Explicit

Public WithEvents App As Word.Application

Private Sub App_WindowActivate(ByVal Doc As Document, ByVal Wn As Window)
    App.Visible = False
End Sub

Private Sub App_WindowDeactivate(ByVal Doc As Document, ByVal Wn As Window)
    App.Visible = False
End Sub

Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
    App.Visible = False
End Sub

ハッシュ値

Sub testGetFileHashMD5()
Debug.Print GetFileHashMD5("C:\Users\Tom\Desktop\test.txt") 'OK
Debug.Print GetFileHashMD5("C:\Users\Tom\Desktop\1Byte.txt") 'OK
Debug.Print GetFileHashMD5("C:\Users\Tom\Desktop\null.txt") '空文字列を返す
End Sub

' 指定したファイルの MD5 ハッシュ値を取得する
Function GetFileHashMD5(fullName As String) As String

    'ハッシュ値作成
    Dim ByteArrayFromBinary
    ByteArrayFromBinary = ReadFileAsBinary(fullName)
    If VarType(ByteArrayFromBinary) <= vbNull Then Exit Function
    Dim md5
    Set md5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
    md5.ComputeHash_2 (ByteArrayFromBinary)
    Dim hashed_16() As Byte
    hashed_16 = md5.hash

    'ハッシュ値文字列化
    Dim msxml
    Set msxml = CreateObject("MSXML2.DOMDocument")
    Dim xmlElement
    Set xmlElement = msxml.CreateElement("tmp")
    xmlElement.DataType = "bin.hex"
    xmlElement.NodeTypedValue = hashed_16
    GetFileHashMD5 = xmlElement.Text
End Function

'指定したファイルのByte型配列を返却する
Function ReadFileAsBinary(fullName As String)
    Const adTypeBinary = 1
    Dim stm
    Set stm = CreateObject("ADODB.Stream")
    stm.Type = adTypeBinary
    stm.Open
    stm.LoadFromFile fullName
    ReadFileAsBinary = stm.Read
End Function