GOLD29VBA

#Excel
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/254362/15732e3a-3cdb-f0ac-5fc7-4806a1668813.png)

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

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/254362/74618e85-7ba7-6b9a-c5f8-bc4273bf1e31.png)

	=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
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/254362/cc02d2a8-62d1-e1bc-a070-ba3a42adc121.png)

#ハッシュ値
	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