カテゴリー: PC

自動的に閉じる制限時間付きMsgBox

自動的に閉じる制限時間付きMsgBox

#If Win64 Then
    ' Excel が64ビット版の場合の関数定義です。
    Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#Else
    ' Excel が32ビット版の場合の関数定義です。
    Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#End If

Sub Macro()

    'MsgBox "おはよう"
    MessageBoxTimeoutA 0&, "おはよう", "2秒で閉じるメッセージ", 0, 0&, 2 * 1000
    
    'MsgBox "こんんちは", 1
    MessageBoxTimeoutA 0&, "こんんちは", "2秒で閉じるメッセージ", 1, 0&, 2 * 1000
    
    'rtn = MsgBox("こんばんわ", 67, "タイトルも変えられますよ")
    rtn = MessageBoxTimeoutA(0&, "こんばんわ", "2秒で閉じるメッセージ", 3, 0&, 2 * 1000)
    
    MessageBoxTimeoutA 0&, "ゆっくりしていってね！！！", "ゆっくり閉じるメッセージ", 0, 0&, 60 * 1000
    
    For i = 0 To 5
        MessageBoxTimeoutA 0&, "type=" & i, "1秒で閉じるメッセージ", i, 0&, 1 * 1000
    Next
    
    For i = 0 To 5
        MessageBoxTimeoutA 0&, "重大なメッセージ" & Chr(13) & "type=" & i & " + 16", "1秒で閉じるメッセージ", i + 16, 0&, 1 * 1000
    Next
    
    For i = 0 To 5
        MessageBoxTimeoutA 0&, "警告クエリ" & vbCrLf & "type=" & i & " + 32", "1秒で閉じるメッセージ", i + 32, 0&, 1 * 1000
    Next
    
    
    For i = 0 To 5
        MessageBoxTimeoutA 0&, "警告メッセージ" & vbCrLf & "type=" & i & " + 48", "1秒で閉じるメッセージ", i + 48, 0&, 1 * 1000
    Next
    
    For i = 0 To 5
        MessageBoxTimeoutA 0&, "情報メッセージ" & vbCrLf & "type=" & i & " + 64", "1秒で閉じるメッセージ", i + 64, 0&, 1 * 1000
    Next
    
    
    MessageBoxTimeoutA 0&, _
    "　　　＿＿＿_∧∧　　／￣￣￣￣￣￣￣￣" & vbCrLf & _
    "　～'　＿＿__(,,ﾟДﾟ)＜　次に逝ってよし！" & vbCrLf & _
    "　　 ＵU 　 　Ｕ U　　＼＿＿＿＿＿＿＿＿" _
    , "10秒で閉じるメッセージ", 0 + 64, 0&, 10 * 1000

End Sub

VBScript

<!-- :
@%windir%\System32\cscript.exe //nologo "%~f0?.wsf"
@exit /b %errorlevel%
-->
<job>
<script language="VBScript">
	Set objShell = WScript.CreateObject("WScript.Shell")
	objShell.Popup "おはよう",5, "5秒で閉じるメッセージ",0
	
	objShell.Popup "こんんちは",5, "5秒で閉じるメッセージ",1
	
	For i = 0 To 5
		objShell.Popup "type=" & i, 1 , "1秒で閉じるメッセージ", i
	Next
	For i = 0 To 5
		objShell.Popup "重大なメッセージ" & Chr(13) & "type=" & i & " + 16",1, "1秒で閉じるメッセージ",i+16
	Next
	For i = 0 To 5
		objShell.Popup "警告クエリ" & Chr(13) & "type=" & i & " + 32",1, "1秒で閉じるメッセージ",i+32
	Next

</script>
</job>

VBA VBScript

VBAでEdge操作を自動化してみた

VBAでEdge操作を自動化してみた。

.NET Frameworkがインストールされていないと、実行時にオートメーションエラーが発生します。オートメーションエラーが発生する場合、.NET Framework 3.5をインストールしてください。

動画ではEdgeでの起動オプションが設定出来ないと言ってますが、 Edgeでの起動オプション変更方法が判明しました！

    'ブラウザを起動
    Dim driver As New Selenium.WebDriver
    Set driver = CreateObject("Selenium.webDriver")

    'Edgeに起動オプションをjsonで渡す
    driver.SetCapability "ms:edgeOptions", "{""args"": [""user-data-dir=" & Replace(fso.BuildPath(CurrentDirectory, "edge_vba1"), "\", "\\") & """" & _
    ",""disable-blink-features=AutomationControlled""" & _
    "] }"

    driver.Start "edge"

VBAで作ったみた。

Option Explicit
#If Win64 Then
    ' Excel が64ビット版の場合の関数定義です。
    Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#Else
    ' Excel が32ビット版の場合の関数定義です。
    Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#End If

Sub Macro()
    Dim driver, o_elem, fso, file, str_user, str_pass, CurrentDirectory, myBy, bFlag, num_trend_word, i
    
    'パスワードファイルを読む
    Set fso = CreateObject("Scripting.FileSystemObject")
    CurrentDirectory = ActiveWorkbook.Path
    Set file = fso.OpenTextFile(fso.BuildPath(CurrentDirectory, "pass1.txt"), 1)
    str_user = file.ReadLine
    str_pass = file.ReadLine
    file.Close
    Set file = Nothing
  
    'Edgeブラウザを起動
    Set driver = CreateObject("Selenium.webDriver")
    
    'EdgeだとAddArgumentが動かない。pythonだと動く
    driver.AddArgument "user-data-dir=" & fso.BuildPath(CurrentDirectory, "edge_vba")
    driver.Start "Edge"
    driver.Get "https://websearch.rakuten.co.jp/"

    Set o_elem = driver.FindElementsByPartialLinkText("ログイン")
    If o_elem.Count > 0 Then
        'ログインしていない  リンクをクリック
        driver.ExecuteScript "arguments[0].click();", o_elem.Item(1)
        'パスワード入力エリアが出現するまで待つ
        Call WaitElementbyCss(driver, "#loginInner_p")
        
        driver.FindElementByCss("#loginInner_p").SendKeys str_pass
        driver.FindElementByCss("#loginInner_u").SendKeys str_user
        driver.FindElementByCss("input.loginButton").Click
    End If
    
    'トレンドワードを配列に格納
    Call WaitElementbyCss(driver, "div.TrendWord-module__trendWordWrap__19AOz input")
    Set o_elem = driver.FindElementsByCss("div.TrendWord-module__trendWordWrap__19AOz input")
    num_trend_word = o_elem.Count
    Dim str_trend_word(5)
    For i = 1 To num_trend_word
        str_trend_word(i - 1) = o_elem.Item(i).Value
    Next
    
    '配列に格納されたトレンドワードを検索する
    For i = 0 To num_trend_word
        '検索窓にトレンドワードを入力する
        Set o_elem = driver.FindElementsByCss("#search-input,#srchformtxt_qt")
        o_elem.Item(1).Clear
        o_elem.Item(1).SendKeys str_trend_word(i)
        '検索ボタンを押す
        Set o_elem = driver.FindElementsByCss("#search-submit,#searchBtn")
        o_elem.Item(1).Click
        MessageBoxTimeoutA 0&, "1秒後、自動に閉じます", "時間待ちです", 1, 65536, 1 * 1000
    Next
    
    'IEを閉じる
    driver.Quit
    Set driver = Nothing
End Sub

Sub WaitElementbyCss(driver, css)
    Dim bFlag, myBy
        bFlag = False
        Set myBy = New By
        Do
            bFlag = driver.IsElementPresent(myBy.css(css))
            driver.Wait 1000
        Loop Until bFlag = True
End Sub

DOSバッチ・VBScriptで作ったみた。

<!-- :
@%windir%\System32\cscript.exe //nologo "%~f0?.wsf"
@exit /b %errorlevel%
-->
<job>
<script language="VBScript">
	Dim driver, o_elem, fso, file, str_user, str_pass, CurrentDirectory, myBy, bFlag, num_trend_word, i

	'パスワードファイルを読む
	Set fso = CreateObject("Scripting.FileSystemObject")
	CurrentDirectory = fso.getParentFolderName(WScript.ScriptFullName)
	Set file = fso.OpenTextFile(fso.BuildPath(CurrentDirectory, "pass1.txt"), 1)
	str_user = file.ReadLine
	str_pass = file.ReadLine
	file.Close
	Set file = Nothing

	'Edgeブラウザを起動
	Set driver = WScript.CreateObject("Selenium.webDriver")
	Set myBy = WScript.CreateObject("selenium.By")

	'EdgeだとAddArgumentが動かない。pythonだと動く
	driver.AddArgument "user-data-dir=" & fso.BuildPath(CurrentDirectory, "edge_vba")
	driver.Start "Edge"
	driver.Get "https://websearch.rakuten.co.jp/"

	Set o_elem = driver.FindElementsByPartialLinkText("ログイン")
	If o_elem.Count > 0 Then
		'ログインしていない  リンクをクリック
		driver.ExecuteScript "arguments[0].click();", o_elem.Item(1)
		'パスワード入力エリアが出現するまで待つ
		Call WaitElementbyCss(driver, "#loginInner_p")

		driver.FindElementByCss("#loginInner_p").SendKeys str_pass
		driver.FindElementByCss("#loginInner_u").SendKeys str_user
		driver.FindElementByCss("input.loginButton").Click
	End If

	'トレンドワードを配列に格納
	Call WaitElementbyCss(driver, "div.TrendWord-module__trendWordWrap__19AOz input")
	Set o_elem = driver.FindElementsByCss("div.TrendWord-module__trendWordWrap__19AOz input")
	num_trend_word = o_elem.Count
	Dim str_trend_word(5)
	For i = 1 To num_trend_word
		str_trend_word(i - 1) = o_elem.Item(i).Value
	Next

	'配列に格納されたトレンドワードを検索する
	For i = 0 To num_trend_word
		'検索窓にトレンドワードを入力する
		Set o_elem = driver.FindElementsByCss("#search-input,#srchformtxt_qt")
		o_elem.Item(1).Clear
		o_elem.Item(1).SendKeys str_trend_word(i)
		'検索ボタンを押す
		Set o_elem = driver.FindElementsByCss("#search-submit,#searchBtn")
		o_elem.Item(1).Click
		WScript.CreateObject("WScript.Shell").popup "1秒後、自動に閉じます",1, "時間待ちです", 1
	Next

	'IEを閉じる
	driver.Quit
	Set driver = Nothing

	Sub WaitElementbyCss(driver, css)
	    Dim bFlag, myBy
	        bFlag = False
	        Set myBy = WScript.CreateObject("Selenium.By")
	        Do
	            bFlag = driver.IsElementPresent(myBy.css(css))
	            driver.Wait 1000
	        Loop Until bFlag = True
	End Sub
</script>
</job>

VBA

VBA/Seleniumでログイン処理

VBA/Seleniumでログイン処理

ログインするVBA

Option Explicit
#If Win64 Then
    ' Excel が64ビット版の場合の関数定義です。
    Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#Else
    ' Excel が32ビット版の場合の関数定義です。
    Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#End If

Sub Macro()
    Dim Driver, o_elem, fso, file, str_user, str_pass, CurrentDirectory, myBy, bFlag
    
    'パスワードファイルを読む
    Set fso = CreateObject("Scripting.FileSystemObject")
    CurrentDirectory = ActiveWorkbook.Path
    Set file = fso.OpenTextFile(fso.BuildPath(CurrentDirectory, "pass1.txt"), 1)
    str_user = file.ReadLine
    str_pass = file.ReadLine
    file.Close
    Set file = Nothing

    
    'クロームブラウザを起動
    Set Driver = CreateObject("Selenium.WebDriver")
    Driver.AddArgument ("user-data-dir=" & fso.BuildPath(CurrentDirectory, "chrome_vba"))
    Driver.Start "chrome"
    Driver.Get "https://websearch.rakuten.co.jp/"
    
    Set o_elem = Driver.FindElementsByPartialLinkText("ログイン")
    If o_elem.Count > 0 Then
        'ログインしていない  リンクをクリック
        Driver.ExecuteScript "arguments[0].click();", o_elem.Item(1)
        'パスワード入力エリアが出現するまで待つ
        bFlag = False
        Set myBy = New By
        Do
            bFlag = Driver.IsElementPresent(myBy.Css("#loginInner_p"))
            Driver.Wait 1000
        Loop Until bFlag = True
        
        Driver.FindElementByCss("#loginInner_p").SendKeys str_pass
        Driver.FindElementByCss("#loginInner_u").SendKeys str_user
        Driver.FindElementByCss("input.loginButton").Click
    End If

    MessageBoxTimeoutA 0, "15秒後、自動に閉じます", "時間待ちです", 1, 65536, 15 * 1000
    
    'IEを閉じる
    Driver.Quit
    Set Driver = Nothing
End Sub

VBA VBScript

VBAでChrome操作を自動化してみた

VBA100本ノックの100本目をやってみた。

VBAで作ったみた。

Sub Macro()
    'クロームブラウザを起動
    Dim Driver, o_elem, i, num_trend_word
    Set Driver = CreateObject("Selenium.WebDriver")
    Driver.Start "chrome"
    Driver.Get "https://websearch.rakuten.co.jp/"

    'トレンドワードを配列に格納
    Set o_elem = Driver.FindElementsByCss("input.TrendWord-module__trendWordText__1uZER")
    num_trend_word = o_elem.Count
    Dim str_trend_word(5)
    For i = 1 To num_trend_word
        str_trend_word(i - 1) = o_elem.Item(i).Value
    Next
    
    '配列に格納されたトレンドワードを検索する
    For i = 1 To num_trend_word
        '検索窓にトレンドワードを入力する
        Set o_elem = Driver.FindElementsByCss("#search-input,#srchformtxt_qt")
        o_elem.Item(1).Clear
        o_elem.Item(1).SendKeys str_trend_word(i)
        '検索ボタンを押す
        Set o_elem = Driver.FindElementsByCss("#search-submit,#searchBtn")
        o_elem.Item(1).Click
        MessageBoxTimeoutA 0&, "5秒後、自動に閉じます", "時間待ちです", 1, 65536, 5 * 1000
    Next
    
    'IEを閉じる
    Driver.Quit
    Set Driver = Nothing
End Sub

DOSバッチ・VBScriptで作ったみた。

<!-- :
@%windir%\System32\cscript.exe //nologo "%~f0?.wsf"
@exit /b %errorlevel%
-->
<job>
<script language="VBScript">
	'IEを起動する
	Set Driver = WScript.CreateObject("Selenium.WebDriver")
	Driver.Start "chrome"  'クロームブラウザを立ち上げます。
	Driver.Get "https://websearch.rakuten.co.jp/"

	'トレンドワードを配列に格納
	Set o_elem = Driver.FindElementsByCss("input.TrendWord-module__trendWordText__1uZER")
	num_trend_word = o_elem.Count
	Dim str_trend_word(5)
	For i = 1 To num_trend_word
	str_trend_word(i - 1) = o_elem.Item(i).Value
	Next

	'配列に格納されたトレンドワードを検索する
	For i = 1 To num_trend_word
		'検索窓にトレンドワードを入力する
		Set o_elem = Driver.FindElementsByCss("#search-input,#srchformtxt_qt")
		o_elem.Item(1).Clear
		o_elem.Item(1).SendKeys str_trend_word(i)
		'検索ボタンを押す
		Set o_elem = Driver.FindElementsByCss("#search-submit,#searchBtn")
		o_elem.Item(1).Click
		WScript.CreateObject("WScript.Shell").popup "5秒後、自動に閉じます",5, "時間待ちです", 1
	Next
	'IEを閉じる
	Driver.Quit
	Set Driver = Nothing
</script>
</job>

wsh-jscript

VBA100本ノックの100本目をやってみた

VBA100本ノックの100本目をやってみた。

VBAで作ったみた。

Sub Macro1()
    'IEを起動する
    Dim objIE As InternetExplorer
    Set objIE = New InternetExplorer
    'IEの位置・大きさの設定、IEを表示
    objIE.Top = 10: objIE.Left = 6160: objIE.Width = 800: objIE.Height = 900
    objIE.Visible = True
    
    objIE.Navigate "https://excel-ubara.com/vba100sample/vba100list.html"
    Call untilReady(objIE)
    'VBA100本ノック目次のtableをとってくる
    Set objTable = objIE.Document.getElementsBytagname("table")
    x_html = objTable(0).outerHTML
    'IEを閉じる
    objIE.Quit
    Set objIE = Nothing
    
    'クリップボードにコピー
    Dim CB As New DataObject
    CB.SetText x_html
    CB.PutInClipboard
    'Sheet1にペーストする
    Set oSheet = ThisWorkbook.Worksheets(1)
    oSheet.Range("A1").PasteSpecial Paste
End Sub
Sub untilReady(objIE As Object)
    Do While objIE.Busy = True Or objIE.ReadyState <> 4
        DoEvents
    Loop
End Sub

DOSバッチ・VBScriptで作ったみた。

<!-- :
@%windir%\System32\cscript.exe //nologo "%~f0?.wsf"
@exit /b %errorlevel%
-->
<job>
<script language="VBScript">
	'このファイルのあるディレクトリをカレントディレクトリに
	Set objShell = Wscript.CreateObject("WScript.shell")
	Set fso      = Wscript.CreateObject("Scripting.FileSystemObject")
	CurrentDirectory = fso.getParentFolderName(WScript.ScriptFullName)

	'IEを起動する
	Dim objIE
	Set objIE = WScript.CreateObject("InternetExplorer.Application")

	'IEの位置・大きさの設定、IEを表示
	objIE.Top = 10: objIE.Left = 6160: objIE.Width = 800: objIE.Height = 900
	objIE.Visible = True

	objIE.Navigate "https://excel-ubara.com/vba100sample/vba100list.html"
	Call untilReady(objIE)
	'VBA100本ノック目次のtableをとってくる
	Set objTable = objIE.Document.getElementsBytagname("table")
	x_html = objTable(0).outerHTML
	'IEを閉じる
	objIE.Quit
	Set objIE = Nothing

	'クリップボードにコピー
	objShell.Exec("clip").StdIn.Write x_html

	'Excel起動
	Set oXlsApp = WScript.CreateObject("Excel.Application")
	'Excelの位置・大きさの設定、Excelを表示
	oXlsApp.Top = 10: oXlsApp.Left = 4460: oXlsApp.Width = 600: oXlsApp.Height = 400
	oXlsApp.Visible = True

	'新規にブックを作成
	Set objWorkbook = oXlsApp.Workbooks.Add
	'Sheet1にペーストする
	Set oSheet = objWorkbook.Worksheets(1)
	oSheet.Range("A1").PasteSpecial Paste
	
	'ブックを名前をつけて保存
	oXlsApp.DisplayAlerts = False
	objWorkbook.SaveAs(fso.BuildPath(CurrentDirectory,"test.xlsx"))
	oXlsApp.DisplayAlerts = True

	'Excelを閉じる
	oXlsApp.Quit
	Set oXlsApp = Nothing


Sub untilReady(objIE)
	'IEがページをロードし終えるのを待つ
	Do While objIE.Busy = True Or objIE.ReadyState <> 4
	WScript.Sleep 1000
	Loop
End Sub

</script>
</job>