kazukazuの備忘録 https://ameblo.jp/kowarusukey/ ~物忘れが激しいのでペタペタ~ ja ga T_CH

]]> https://ameblo.jp/kowarusukey/entry-12840902799.html Fri, 16 Feb 2024 23:38:57 +0900 Selenium Declare PtrSafe Sub mouse_event Lib "USER32" (ByVal dwFlags As Long, _
                                                     Optional ByVal dx As Long = 0, _
                                                     Optional ByVal dy As Long = 0, _
                                                     Optional ByVal dwDate As Long = 0, _
                                                     Optional ByVal dwExtraInfo As Long = 0)
Declare PtrSafe Function SetCursorPos Lib "USER32" (ByVal x As Long, ByVal y As Long) As Long


Sub sample()
    Dim driver As New selenium.WebDriver
    
    Dim myBy As New By
    
    driver.Start "chrome"
    Application.Wait Now() + TimeValue("00:00:01")
    driver.Get "https://www.yahoo.co.jp/"
    
    Application.Wait Now() + TimeValue("00:00:05")
    
    If driver.IsElementPresent(myBy.XPath("//*[@id=""Perorin""]/div/div/div[2]/a")) Then
       'MsgBox "ある"
       driver.FindElementByXPath("//*[@id=""Perorin""]/div/div/div[2]/a").Click
    Else
       'MsgBox "ない"
    End If
    
    Application.Wait Now() + TimeValue("00:00:01")
    
    
    TEXTT = Range("A1").Value
    
    'driver.FindElementByCss("#ContentWrapper > header > section._1o9PYyvuVafb5hd9eJ9rYX > div > form > fieldset > span > input").SendKeys (TEXTT)
    'Driver.FindElementByCss("#ContentWrapper > header > section._1o9PYyvuVafb5hd9eJ9rYX > div > form > fieldset > span > button").Click

    'Driver.SwitchToWindowByTitle ("Yahoo!JAPAN")

    driver.ExecuteScript ("window.open('https://www.google.co.jp/')")
    
    Application.Wait Now() + TimeValue("00:00:03")
    driver.SwitchToPreviousWindow

    
    'wTitle = driver.window.Title
    'driver.SwitchToWindowByTitle (wTitle)
    
    
    '//*[@id="yDmH0d"]/c-wiz/div/div/c-wiz/div/div/div/div[2]/div[2]/button
    If driver.IsElementPresent(myBy.Css("#yDmH0d > c-wiz > div > div > c-wiz > div > div > div > div.DRc6kd.bdn4dc > div.QlyBfb > button")) Then
       'MsgBox "ある"
       driver.FindElementByCss("#yDmH0d > c-wiz > div > div > c-wiz > div > div > div > div.DRc6kd.bdn4dc > div.QlyBfb > button").Click
    Else
       'MsgBox "ない"
    End If
    
    Application.Wait Now() + TimeValue("00:00:03")
    
    driver.ExecuteScript ("window.open('https://www.google.com/maps?authuser=0')")
    'wTitle = driver.window.Title
    
    'https://www.google.com/maps?authuser=0
    
    'Driver.SwitchToWindowByTitle (wTitle)
    'Driver.SwitchToWindowByTitle ("Yahoo! JAPAN")

    'Driver.SwitchToNextWindow
    'driver.SwitchToPreviousWindow
    
    Application.Wait Now() + TimeValue("00:00:05")
    driver.SwitchToWindowByTitle ("Google")

    Application.Wait Now() + TimeValue("00:00:01")

driver.FindElementByCss("#APjFqb").SendKeys (TEXTT)
Application.Wait Now() + TimeValue("00:00:07")


driver.FindElementByXPath("/html/body/div[1]/div[3]/form/div[1]/div[1]/div[2]/div[2]/div[5]/center/input[1]").Click

Application.Wait Now() + TimeValue("00:00:05")





    






SERU = 1

    Dim LinkURL As Variant 'As HTMLAnchorElement
     
    For Each LinkURL In driver.FindElementsByTag("a").Attribute("href")
        'Debug.Print LinkURL
        'Application.Wait Now() + TimeValue("00:00:01")
        Range("C" & SERU).Value = LinkURL
        SERU = SERU + 1
        
    Next LinkURL

Application.Wait Now() + TimeValue("00:00:03")
driver.FindElementByLinkText("https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14230383004").Click



'’body > div.L3eUgb > div.o3j99.ikrT4e.om7nvf > form > div:nth-child(1) > div.A8SBwf > div.FPdoLc.lJ9FBc > center > input.gNO89b


Application.Wait Now() + TimeValue("00:00:01")
driver.Close

Application.Wait Now() + TimeValue("00:00:02")

driver.SwitchToNextWindow
driver.Close

Application.Wait Now() + TimeValue("00:00:02")

driver.SwitchToWindowByTitle ("Yahoo! JAPAN")














    Dim WshShell As Object

        Set WshShell = CreateObject("WScript.Shell")
        With WshShell
        
        Application.Wait Now() + TimeValue("00:00:03")
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True
            .SendKeys "^{W}", True

        End With
        Set WshShell = Nothing









    'Debug.Print Driver.IsElementPresent(myBy.XPath("//*[@id=""Perorin""]/div/div/div[2]/a"))
    If driver.IsElementPresent(myBy.XPath("//*[@id=""Perorin""]/div/div/div[2]/a")) Then
       MsgBox "ある"
       driver.FindElementByXPath("//*[@id=""Perorin""]/div/div/div[2]/a").Click
    Else
       'MsgBox "ない"
    End If


    
    
'//*[@id="Perorin"]/div/div/div[2]/a
    driver.Close
    Set driver = Nothing
End Sub


 

]]> https://ameblo.jp/kowarusukey/entry-12830501986.html Tue, 28 Nov 2023 23:43:00 +0900 Word Sub test()


Dim objWord As Word.Application
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
    
'--- 開くワードドキュメントのパス ---'
Dim docPath As String
docPath = "\\GAS 2014-08.pdf"

'--- 開いたワードドキュメントを格納する変数 ---'
Dim docDoc As Word.Document


Dim objDoc
Set objDoc = objWord.Documents.Open(docPath)


'On Error Resume Next
'Call AppActivate("GAS 2014-08 - Word")
'On Error GoTo 0


objDoc.StoryRanges(wdMainTextStory).Copy
'objDoc.Selection.Copy


'ThisWorkbook.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'ThisWorkbook.Worksheets("Sheet1").Range("A1").Paste
ActiveSheet.Paste

Range("A2").Select



Dim buf As New DataObject
buf.SetText ""
buf.PutInClipboard
'objWord.Documents.Close SaveChanges:=wdDoNotSaveChanges
objWord.Quit


End Sub

]]> https://ameblo.jp/kowarusukey/entry-12727445679.html Thu, 17 Feb 2022 21:55:26 +0900 効果音のリンク（wavファイル） https://soundcloud.com/user-483021709/1-1

https://soundcloud.com/user-483021709/2-1

]]> https://ameblo.jp/kowarusukey/entry-12689576267.html Sat, 31 Jul 2021 16:58:04 +0900 罫線を察知するコード Sub TEST()

Dim SERU As Long
Dim KEISEN

SERU= 1
For SERU = 1 To 100

    Set KEISEN= Range("A" & SERU).Borders
    
    If KEISEN.LineStyle = -4142 Then
    Else
       MsgBox SERU & " 行目。　　最終行取得成功！" & vbCrLf & _
              "A" & SERU & " セルの周辺に罫線が存在します。", vbInformation, "成功"
    End If

Next SERU


End Sub

]]> https://ameblo.jp/kowarusukey/entry-12688699426.html Mon, 26 Jul 2021 20:30:49 +0900 バージョン確認　その他諸々 Sub OSバージョン確認1()
 
  MsgBox "OS Version : " & Application.OperatingSystem, vbInformation
 
End Sub


Sub OSバージョン確認2()
    Dim Locator, Service, OsSet, os, msg As String
    Set Locator = CreateObject("WbemScripting.SWbemLocator")
    Set Service = Locator.ConnectServer
    Set OsSet = Service.ExecQuery("Select * From Win32_OperatingSystem")
    For Each os In OsSet
        msg = msg & os.Caption & vbCrLf
        msg = msg & os.Version
    Next os
    MsgBox msg, vbInformation
    Set Service = Nothing
    Set OsSet = Nothing
    Set Locator = Nothing
End Sub



Sub EXCELバージョン確認()
    MsgBox Application.Version
End Sub

 

指定NotePad起動

Sub TestMain()
    Dim strFile As String, TTT As String
    'ファィルのフルパスを指定
    strFile = "C:\Users\great\Desktop\777.txt"
  
    If Dir(strFile) = "" Then
        MsgBox "ファイルが存在しません。"
        Exit Sub
    End If
    
    TTT = "777"
    
   Shell "notepad C:\Users\great\Desktop\" & TTT & ".txt", 1


End Sub

 

 

 

 

 

 

]]> https://ameblo.jp/kowarusukey/entry-12683076670.html Sun, 27 Jun 2021 13:40:59 +0900 【上】フォルダ選択（ダイアログ）　【下】フォルダ内のすべてのファイルに対する処理 Sub Sample2()
    Dim Shell, myPath
    Set Shell = CreateObject("Shell.Application")
    Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
    
    If Not myPath Is Nothing Then
       MsgBox myPath.Items.Item.Path & vbCrLf & _
              myPath
    Else
    End If
    
    Set Shell = Nothing
    Set myPath = Nothing
End Sub

 

 

 

 

 

Sub OpenFilesInFolder()

    Dim path, fso, file, files
    path = "C:/Users/xxxxxx/フォルダ名/"
    'path = ThisWorkbook.Path & "/フォルダ名/"  '相対パスの場合
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set files = fso.GetFolder(path).files

    'フォルダ内の全ファイルについて処理
    For Each file In files

        'ファイルを開いてブックとして取得
        Dim wb As Workbook
        Set wb = Workbooks.Open(file)

        'ブックに対する処理

        '保存せずに閉じる
        Call wb.Close(SaveChanges:=False)

    Next file

End Sub

]]> https://ameblo.jp/kowarusukey/entry-12682241646.html Wed, 23 Jun 2021 05:51:10 +0900 フォルダごとコピー Sub フォルダごとコピー()

    Dim FSO As Object
    Dim MOTO As Variant
    Dim SAKI As Variant
    
    MOTO = "C:\Users\great\Desktop\コピー元"
    SAKI = "C:\Users\great\Desktop\新しいフォルダー\"

    Set FSO = CreateObject("Scripting.FileSystemObject")

    FSO.GetFolder(MOTO).Copy SAKI

    Set FSO = Nothing

End Sub

]]> https://ameblo.jp/kowarusukey/entry-12681508712.html Sat, 19 Jun 2021 12:28:24 +0900 ListBox Dim MaxRow As Long

MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
UserForm1.ListBox1.RowSource = "Sheet1!A1:A" & MaxRow

UserForm1.Show

]]> https://ameblo.jp/kowarusukey/entry-12681465436.html Sat, 19 Jun 2021 07:58:17 +0900 Outlookメール取得コード Sub Sample1()
 
 Dim objOutlook, objNamespace, objFolder As Object
 Dim i As Long
  
 'Outlookオブジェクトの生成
 Set objOutlook = CreateObject("Outlook.Application")
 '名前空間を取得
 Set objNamespace = objOutlook.GetNamespace("MAPI")
 '対象フォルダ選択用のダイアログボックスを表示する
 Set objFolder = objNamespace.PickFolder
 
 On Error GoTo TTT
 If objFolder = "" Then
TTT:
    Exit Sub
 Else
 End If
  
 '対象フォルダ内全てのアイテムに対し処理を行う
 For i = 1 To objFolder.Items.Count
   'メールアイテムであれば処理実行
   If objFolder.Items(i).Class = 43 Then
       '「送信者名」をセルA列に書込み
       Cells(i + 1, 1).Value = objFolder.Items(i).SenderName
       '「メールタイトル」をセルB列に書込み
       Cells(i + 1, 2).Value = objFolder.Items(i).Subject
       '「受信日時」をセルC列に書込み
       Cells(i + 1, 3).Value = objFolder.Items(i).ReceivedTime
       '「本文」をセルD列に書込み
       'Cells(i + 1, 4).Value = objFolder.Items(i).Body
       ´開封済みは否か
       Cells(i + 1, 5).Value = objFolder.Items(i).UnRead
       ´分類取得
       Cells(i + 1, 6).Value = objFolder.Items(i).Categories
       
    End If
  Next
   
  'セットした変数を解除
  Set objOutlook = Nothing
  Set objNamespace = Nothing
 
End Sub

]]> https://ameblo.jp/kowarusukey/entry-12670383625.html Sat, 24 Apr 2021 08:35:19 +0900