VBAで価格コムの洗濯機ランキングを取得してみる。
Option Compare Database Option Explicit Private Sub コマンド0_Click() Dim ieobj As InternetExplorer Set ieobj = New InternetExplorer ieobj.navigate ("https://kakaku.com/kaden/washing-machine/ranking_2110/hot/") ieobj.Visible = True 'Webブラウザ読込が完了するまで待つ Call IEWait(ieobj) 'IEを待機 Dim doc As HTMLDocument Set doc = ieobj.Document Dim el As IHTMLElement Dim detailel As IHTMLElement Dim rankingString As String '更新日を取得 Debug.Print (doc.getElementsByClassName("notice alignR mTop5")(0).innerText) For Each el In doc.getElementsByClassName("rkgContents")(0).all If el.className = "num" Then rankingString = el.innerText & "位" End If If el.className = "rkgBoxNameMaker" Then rankingString = rankingString & " " & el.innerHTML End If If el.className = "rkgBoxNameItem" Then rankingString = rankingString & " " & el.innerHTML End If If el.className = "price" Then rankingString = rankingString & " " & el.innerText Debug.Print rankingString End If Next el Call WaitFor(3) ieobj.Quit Set ieobj = Nothing End Sub Function IEWait(ByRef objIE As Object) Do While objIE.Busy = True Or objIE.ReadyState <> 4 DoEvents Loop End Function Function WaitFor(ByVal second As Integer) Dim futureTime As Date futureTime = DateAdd("s", second, Now) While Now < futureTime DoEvents Wend End Function
帳票フォームにボタン付けてもVisible設定できません。
はい、帳票フォームにボタンつけたら色々できそうですよね。
レコードの内容によってボタンの表示・非表示をコントロールしたいですよね。
はい！できません。
まぁ、レコードごとにボタンみたいなコントロールつけて管理してたら
システム不安定になるからでしょうかね・・・
代わりにテキストボックスを作って、データコントロールに
iif文で文字列を制御するくらいならできます。
こんな感じで制御しておき、
こんな感じで明細行のフィールドを判断条件にすれば
ボタンチックな動きができるらしい。
Private Sub テキスト5_Click()
If Me.右 = "xxx" Then
MsgBox "xxx"
Else
End If
End Sub
|<
Excelファイルを開かずにパスワード有無を確認するには・・・
Excelでセルに=[Bファイル]Sheet1!$A$1
と書いてExcelファイルを開かずに他のファイルのセル値を取得することができますよね？
それをexcelVBAで下の様に書くと、パスワードがかかったファイルは＃Ref!になって検出できます。
Sub ボタン1_Click() Dim A As String Dim cnt As Long On Error Resume Next A = Dir("c:\Work\*.xlsx") Application.DisplayAlerts = False Do While A <> "" cnt = cnt + 1 Cells(cnt, 1) = A SendKeys "{ESC}" Cells(cnt, 2) = "='c:\Work\[" & A & "]Sheet1'!A1" A = Dir() Loop Application.DisplayAlerts = True With Range(Range("B1"), Range("B1").End(xlDown)) .Value = .Value End With End Sub
Option Compare Database Option Explicit Private Sub cmdCreateExcelFiles_Click() Dim DesktopPath As String, FilePath As String, WSH As Variant Set WSH = CreateObject("Wscript.Shell") DesktopPath = WSH.SpecialFolders("Desktop") 'FilePath = DesktopPath & "\work" & "\CreatedByVBAFile.xlsx" Dim i As Long For i = 1 To 100 FilePath = DesktopPath & "\work" & "\CreatedByVBAFile" & i & ".xlsx" Call CreateExcelFiles(FilePath) Next i Set WSH = Nothing End Sub Private Sub cmdCheckPass_Click() Dim ExApp As Object Set ExApp = CreateObject("Excel.Application") ExApp.Visible = True Dim DesktopPath As String, FilePath As String, WSH As Variant Set WSH = CreateObject("Wscript.Shell") DesktopPath = WSH.SpecialFolders("Desktop") FilePath = DesktopPath & "\createdExcel.xlsx" ExApp.Workbooks.Add Dim A As String Dim cnt As Long On Error Resume Next A = Dir("C:\Users\ユーザー名\Desktop\work\*.xlsx") ExApp.DisplayAlerts = False Do While A <> "" cnt = cnt + 1 ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 1) = A ExApp.SendKeys "{ESC 3}" ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 2) = "='C:\Users\ユーザー名\Desktop\work\[" & A & "]Sheet1'!A1" If (IsError(ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 2))) Then ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 3) = "Locked" Else ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 3) = "---" End If A = Dir() Loop ' With Range(Range("B1"), Range("B1").End(xlDown)) ' .Value = .Value ' End With With ExApp.Workbooks(ExApp.Workbooks.Count) .SaveAs FileName:=FilePath .Close End With ExApp.Quit Set ExApp = Nothing Set WSH = Nothing End Sub Private Sub CreateExcelFiles(getFileName As String) Dim ExApp As Object Set ExApp = CreateObject("Excel.Application") ExApp.Visible = False Dim DesktopPath As String, FilePath As String, WSH As Variant Set WSH = CreateObject("Wscript.Shell") DesktopPath = WSH.SpecialFolders("Desktop") FilePath = getFileName ExApp.Workbooks.Add With ExApp.Workbooks(ExApp.Workbooks.Count) .Sheets(1).Cells(1, 1) = Now() .SaveAs FileName:=FilePath .Close End With ExApp.Quit Set ExApp = Nothing Set WSH = Nothing End Sub
Access vba でexcelを操作してみる
参考にさせていただきました。
note.com
Public Sub excelSample() Dim xlApp As Object 'Excelアプリ' Dim xlBook As Object 'Excelブック' Dim xlSheet As Object 'Excelシート' Set xlApp = CreateObject("Excel.Application") xlApp.Visible = True Set xlBook = xlApp.Workbooks.Open("C:\Users\xxxxxxx\Desktop\sampleExcel.xlsx") Set xlSheet = xlBook.Worksheets("Sheet1") ' ブックの全シートを 1 つずつループして処理する Dim objSheet As Worksheet For Each objSheet In xlBook.Worksheets Debug.Print objSheet.Name & "を処理します" 'A1セルにシートの名前を書き込む objSheet.Cells(1, 1) = "このシートの名前は" & objSheet.Name & "です。" 'シートを印刷する。 objSheet.PrintOut Next ' Set rs = Nothing Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing End Sub
Private Sub dispExcelData(ByVal recievedFullPath As String) Dim xlApp As Object 'Excelアプリ' Dim xlBook As Object 'Excelブック' Dim xlSheet As Object 'Excelシート' Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False xlApp.Application.DisplayAlerts = False Set xlBook = xlApp.Workbooks.Open(recievedFullPath) 'Set xlSheet = xlBook.Worksheets("Sheet1") ' ブックの全シートを 1 つずつループして処理する Dim objSheet As Object Dim rng As Object For Each objSheet In xlBook.Worksheets objSheet.Activate Debug.Print objSheet.Name & "を処理します*****************" Set rng = objSheet.range("A1:B6") Dim vnt As Variant vnt = rng.Value Dim msg As String Dim x As Integer Dim i As Long msg = "" For x = 1 To UBound(vnt) msg = msg & vnt(x, 1) & " " & vnt(x, 2) & vbCrLf Next MsgBox msg Dim testString As String testString = objSheet.range("B2").Value MsgBox testString testString = objSheet.range("B3").Value MsgBox testString testString = objSheet.range("B4").Value MsgBox testString testString = objSheet.range("B5").Value MsgBox testString objSheet.range("B2").Value = "cccc" objSheet.range("B2").interior.colorindex = 4 objSheet.range("A6").ShrinkToFit = True Debug.Print objSheet.Name & "を処理終了*****************" Next objSheet 'xlApp.Quit xlBook.Save xlApp.Application.DisplayAlerts = True xlBook.Close xlApp.Quit ' Set xlSheet = Nothing ' Set xlBook = Nothing ' Set xlApp = Nothing End Sub
VBAでコマンドプロンプトたたいた結果を受け取ろう
参考にさせていただきました。
officetanaka.net
Sub xpdf_pdfinfo_getInformation()
Dim WSH, wExec, sCmd As String, Result As String
Set WSH = CreateObject("WScript.Shell") ''(1)
sCmd = "dir C:\"
sCmd = "C:\Users\xxxx\Desktop\test\pdfinfo.exe C:\Users\xxxx\Desktop\test\no.pdf" ''(2)
sCmd = "C:\Users\xxxx\Desktop\test\pdfinfo.exe C:\Users\xxxx\Desktop\test\password.pdf" ''(2)
Set wExec = WSH.Exec("%ComSpec% /c " & sCmd) ''(3)
Do While wExec.Status = 0 ''(4)
DoEvents
Loop
Result = wExec.StdOut.ReadAll ''(5)
MsgBox Result
Set wExec = Nothing
Set WSH = Nothing
End Sub
VBAでリストにプリンター一覧を追加し、選択したプリンタでPDFを印刷する。
以下の感じでリストにアイテムを追加する。
Private Sub Form_Load()
'フォーム読み込み時
Dim prt As Printer
'すべてのプリンタを列挙してコンボボックスの値集合ソースに追加
For Each prt In Application.Printers
Me.リスト10.AddItem prt.DeviceName
Next prt
End Subボタンが押されたら、PDFの印刷をするのですが、
ここでどのプリンタを選択するかは上記でセットしたリストの値に置き換えています。
Private Sub コマンド12_Click()
'[印刷]ボタンクリック時
'プリンタ変数を宣言
Dim prtDefault As Printer
'現在のプリンタ設定を退避
Set prtDefault = Application.Printer 'これがデフォルトプリンタ
'選択されたプリンタの情報を設定
Set Application.Printer = Application.Printers(Me.リスト10.Value)
'印刷するぞ
'シェルオブジェクトの作成
Dim shellObj As Object
Set shellObj = CreateObject("WScript.shell")
Dim exeStm As String
'コマンドラインの文字列を作成する
exeStm = "AcroRd32.exe /t" & " " & "C:\Users\XXXXX\Desktop\test.pdf" & " " & Application.Printer.DeviceName
shellObj.Run (exeStm) '印刷する
'プリンタ設定を元に戻す
Set Application.Printer = prtDefault
Set prtDefault = Nothing
End Subexcelファイルの印刷時にプリンタを指定するならば、以下の感じで！
myExcel.ActiveWorkbook.PrintOut ActivePrinter:=Me.リスト10
PowerShell？？なんですかそれ？
WikiってみるとAS400のCLにも影響をうけているらしいので
とっつきやすいかも？
tonari-it.com
