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