EXCEL VBA エクセルから秀丸マクロを実行して、マクロ実行完了後に結果を取得したい
タイトルの通り、
エクセルから秀丸マクロを実行してマクロの実行完了後、結果を取得する方法を掲載する。(秀丸マクロでgrepした結果をファイルに保存、保存したファイルをエクセルで読み出す方法で結果を取得しています。)
この方法で外部バッチファイル等の実行待ちもできる。
◆エクセル実行画面
実行シート
結果出力シート
◆エクセル実行シートのVBAソース
Option Explicit '変数宣言絶対するマン 'シート名定義 Const cExecSheetName As String = "実行シート" Const cOutSheetName As String = "結果出力シート" '定数定義 Const cForReadin As Integer = 1 '読み取り専用でファイルを開く '実行時の入力に関する定数 Const cRows_HidemaruExe As Long = 4 '秀丸実行ファイルパス Const cRows_MacroFile As Long = 5 '秀丸マクロ格納パス Const cRows_GrepLogFileFolder = 6 'grep対象フォルダ Const cRows_GrepLogFile As Long = 7 'grep対象ファイル 'VBAから秀丸マクロを実行して処理完了待ち後に実行結果を取得する Public Sub Exec_HidemaruMacro() '各ファイルのパス取得用変数 Dim strHidemaru As String Dim strMacroFile As String Dim strLogPath As String Dim strLogFile As String 'VBA実行シートオブジェクト Dim objExecWsh As Object Set objExecWsh = ThisWorkbook.Worksheets(cExecSheetName) '秀丸の実行ファイルパス取得 strHidemaru = CStr(objExecWsh.Cells(cRows_HidemaruExe, 2).Value) 'マクロファイル格納パス取得 strMacroFile = CStr(objExecWsh.Cells(cRows_MacroFile, 2).Value) 'grep対象格納フォルダパス取得 strLogPath = CStr(objExecWsh.Cells(cRows_GrepLogFileFolder, 2).Value) 'grep対象格納ファイルパス取得 strLogFile = CStr(objExecWsh.Cells(cRows_GrepLogFile, 2).Value) '秀丸マクロ実行コマンド作成 Dim Command As String Command = """" & strHidemaru & """ /r" & " " & """" & strLogPath & "\" & strLogFile & """" Command = Command & " /x """ & strMacroFile & """" 'シェルコマンドを使用して処理完了待ちで実行 Dim wsh As Object Set wsh = CreateObject("WScript.Shell") wsh.Run Command, 0, True '---秀丸マクロ実行から実行完了待ちここまで------------------------------------ '例えば、秀丸マクロでgrepした結果をテキストファイルに保存して、その結果を取得する '出力ファイルパスを取得 Dim strGrepFile As String strGrepFile = strLogPath & "\" & "grep結果.txt" 'grep結果を保存したファイルを開く Dim objFs As Object Dim objStream As Object Dim strLine As String Dim lRow As Long Dim lColnm As Long Dim cnt As Long Set objFs = CreateObject("Scripting.FileSystemObject") If False = objFs.FileExists(strGrepFile) Then 'MsgBox "grep結果ファイルが存在しません",vbOKOnly, "エラー" Else '読み取り専用で開く Set objStream = objFs.OpenTextFile(strGrepFile, 1, 2) '出力行タイトル1行目、2行目から出力 lColnm = 1 lRow = 2 'EOFまでループ Do While objStream.AtEndOfStream <> True 'ここを一括取得や配列にすると高速化可能 '1行ずつ取得 strLine = objStream.ReadLine 'セルに値を設定 ThisWorkbook.Worksheets(cOutSheetName).Cells(lRow, lColnm).Value = strLine '出力行を次の行へカウント lRow = lRow + 1 Loop 'EOFで抜けたらファイルストリームを閉じる objStream.Close End If '後処理 '不要でもSetしたものはクリアする Set objStream = Nothing Set objFs = Nothing Set wsh = Nothing Set objExecWsh = Nothing End Sub
$search_str[0]="検索文字列"; $filename[0]="C:\\Users\\username\\Documents\\VBA\\grep結果.txt"; //起動した秀丸のハンドルを取得 //秀丸をファイル名を指定、マクロを指定して起動すると //2つウィンドウが起動してしまうため、 //ファイル名を指定して起動したウィンドウへ移動し、 //マクロを起動したウィンドウを閉じる #closehandle = hidemaruhandle(0); prevhidemaru; #HWND = hidemaruhandle(0); setactivehidemaru #HWND; closehidemaru #closehandle; localgrep $search_str[0],regular; //今開いたgrepウィンドウのハンドラを取得 //#HWND_GREP = hidemaruhandle(0); //grep結果を保存して閉じる $file = $filename[0]; saveas $file,sjis; //マクロ実行ウィンドウに戻る setactivehidemaru #HWND; //秀丸終了 exitall;
検索ログファイル(grep用ファイル.log)
ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ あああああああああ検索文字列1ああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああ検索文字列2あああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ ああああああああああああああああああああああああああああああ
EXCEL VBA 別ファイルのシートから図形を含めてコピーしたい
今やっているのは、VBAで別のエクセルファイルからシートの内容を範囲を指定してコピーして貼り付けるという単純なこと。
だが、落とし穴がたくさんあった。
普通にコピーメソッドを使って貼り付けをするとコピーの処理落ちや図形がコピーできなかったり、図形位置がずれる等の不具合が発生した。
図形の貼り付け時の位置ずれは、いまだ苦戦中のため、VBAに詳しい方ヘルプです。
◆発生した不具合や落とし穴
・コピーメソッド、ペーストメソッドが処理負荷により失敗する。WaitやSleepで待つ必要がある。
・Shapesオブジェクトをループで取得して貼り付けを実行すると、コメントはコピーメソッドに対応していないためエラーが発生する。
・Shapesオブジェクトがグループ化されていると貼り付け位置がずれる。(未解決)
・ShapesオブジェクトのTop、LeftはSingle型だが、Rangeの位置はDouble型
EXCEL VBA 図形を含めて最終行や最終列を取得したい
EXCEL VBAで使用セルの最終行や最終列を取得したいとgoogle検索をすると
よく紹介されているのは、表の最終行や列を取得する方法。
しかし実際は図形が含まれているシートの使用最終行列を求めたい場合がある。
ばらばらに記載されていることが多かったためまとめて実装に近いものを記載する。
Option Explicit '強制変数宣言指定 Option Base 0 '配列の要素番号0から '最終行列取得タイプ Const cLineTypeRow As Integer = 0 Const cLineTypeCol As Integer = 1 Function getLastLine() Dim trgwsh As Worksheet Dim strMaxLine As Variant Dim shpMaxLine As Variant Dim EndRow As Long Dim EndCol As Long '最終行列を取得するワークシートを設定 Set trgwsh = ThisWorkbook.Worksheets(1) 'ターゲットワークシートの文字の最終行列を取得 strMaxLine = getLastStrLine(trgwsh) 'ターゲットワークシートのShapesオブジェクトの最終行列を取得 shpMaxLine = getLastShapeLine(trgwsh) '行列分解 EndRow = Application.Max(strMaxLine(cLineTypeRow), shpMaxLine(cLineTypeRow)) EndCol = Application.Max(strMaxLine(cLineTypeCol), shpMaxLine(cLineTypeCol)) 'デバッグ用出力 Debug.Print "最終行" & EndRow & "最終列" & EndCol '列をアルファベット変換 'Split(Cells(1, EndCol).Address(True, False), "$")(0) Debug.Print "最終行列セル" & Split(Cells(1, EndCol).Address(True, False), "$")(0) & EndRow End Function Function getLastStrLine(wsh As Worksheet) As Variant Dim EndLine(1) As Long 'UsedRangeで使用した履歴のあるセルを最終行列とする EndLine(cLineTypeRow) = wsh.UsedRange.Item(wsh.UsedRange.Count).Row EndLine(cLineTypeCol) = wsh.UsedRange.Columns(wsh.UsedRange.Columns.Count).Column getLastStrLine = EndLine End Function Function getLastShapeLine(wsh As Worksheet) As Variant Dim EndLine(1) As Long Dim shp As Shape If wsh.Shapes.Count > 0 Then 'Shapesオブジェクトの最終行を取得 For Each shp In wsh.Shapes EndLine(cLineTypeRow) = Application.Max(EndLine(cLineTypeRow), shp.BottomRightCell.Row) EndLine(cLineTypeCol) = Application.Max(EndLine(cLineTypeCol), shp.BottomRightCell.Column) Next Else '図形がない場合、A1を設定 EndLine(cLineTypeRow) = 1 EndLine(cLineTypeCol) = 1 End If getLastShapeLine = EndLine End Function
EXCEL VBA 環境依存文字を含むファイルパスをバイナリ形式で開きたい
ファイルをバイナリ形式で開きたいが、ファイルパスが256文字以上だったり
環境依存文字が含まれている場合、Dir関数が対応しておらず、開くことができない。
そんなときの対処法は
FileSystemObjectを使用してShortPathでファイルを取得する。
そうすると環境依存文字が含まれず、短いパスでファイルを指定することができる。
念のためにDirでファイルが取得できるか判定することで回避することもできる。
Sub hogehoge() Dim FSO As Object
Dim FilePath As String FilePath = "XXXXXXXXXXXXXX" Set FSO = CreateObject("Scripting.FileSystemObject") MsgBox FSO.GetFile(FilePath).ShortPath Set FSO = Nothing End Sub
EXCEL VBA AcrobatReaderやAdobeを使わずにPDFのページ数を取得する方法
dタイトルの通り、
EXCEL VBA AcrobatやAdobeを使わずにPDFのページ数を取得したい
と思ったときにめちゃくちゃ調べまわったのでその結果をまとめる。
結論から言うと、イメージしていたやり方では
PDFのある特定のバージョンで特定の構造の場合は取得できるが、
取得できない場合があった。
以下調査結果まとめ
<調査結果まとめ>
◆VBAでPDFのPages【ページズ】コレクションのCount【カウント】プロパティにはアクセスできない(AdobeでWindowsのプロパティはサポートしていないため)
◆PDFをバイナリ形式で開き、正規表現でページタグになる部分をカウントしたり、値を取得する。
イメージはこれが一番近いが、取得できないPDFがある。PDFをテキストエディタで開くとわかるが、正規表現に該当しないパターンのファイルはページ数が取得できない。
VBA Page Count | MrExcel Message Boardより
https://www.mrexcel.com/board/threads/vba-page-count.347911/page-2
しかし、実行してみると14行目のページ総数が64となっているが実際は1ページのPDFファイルのため、実行結果にミスがあることがわかる。
そのため、確実に正しい結果が取得できる正規表現にしぼる必要があった。
実行画面
◆フリーソフトでページ数を表示できるものがある
ComPDFというツールで取得できるらしい。(試していない)
ツールダウンロード:http://www.ne.jp/asahi/foresth/home/にアクセスしComPDFをダウンロード
紹介していたページ:「バヤシのブログ」さん
【時短テクニック】複数のPDFのページ数を開かずにカウントする方法
https://salaryman-knowhow.com/pdf-page-count/
◆VBAでPDFファイルを開き、文書のプロパティを開き、ページ数を取得する
これが現段階では最強ではなかろうか。
64bit版は先頭のライブラリの定義を差し替えるといけると思います。
とりあえず実行できるところまで試した。(DCをインストールしたくない)
そのまま実行したらエラーが発生した。
参照設定「UIAutomationClient」の設定が必要。
なんとコメントに書いてあったが見逃していたw
「初心者備忘録」さん
Acrobat Reader DCを利用してPDFファイルのページ数を取得するVBAマクロ
https://www.ka-net.org/blog/?p=11981
◆上記を踏まえ、おまけで私が実装した妥協PDF、エクセル、ワードのページ数取得マクロ
・一部PDFのページ数が取得できません。
・シート名”一覧”としているため、strListの定義を変えれば任意のシート名に変更できます。
・検索対象のフォルダはB2セルに入力するようにしているのでダイアログ表示にするなど変更してください。
・取得できないパターンはエラー文言をセルに出力するようにしています。
実行画面
以下ソース
Option Explicit
'※64ビット版Officeで実行する場合は要コード変更
'UIAutomationClient(UIAutomationCore.dll)要参照
#If Win64 Then
Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lparam As LongPtr) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Function PostMessage Lib "user32" Alias "PostMessageA"(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lparam As Long) As Long
Private Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)
#End If
Private Const WM_COMMAND As Long = &H111
Dim rowCntOutput As Long
Dim cntListNum As Long
Const strList As String = "一覧"
Const rowTitle As Long = 5
Const colNo As Long = 2
Const colPath As Long = 3
Const colFile As Long = 4
Const colPage As Long = 5
Const rowList As Long = 200 'リスト最大200行
'リストクリア関数
Sub delFileList()
Dim wsh As Worksheet
Set wsh = ThisWorkbook.Worksheets(strList)
'タイトル行の次からリスト最大行までのRangeをクリア
wsh.Range( _
wsh.Cells(rowTitle + 1, colNo), _
wsh.Cells(rowList, colPage)).Clear
'ワークシートオブジェクトは後処理不要という記述もあるが、明示的にクリアする。
Set wsh = Nothing
End Sub
'ファイルリスト取得メイン処理
Sub FileList()
Dim listwsh As Worksheet
Dim strPath As String
Set listwsh = ThisWorkbook.Worksheets(strList)
strPath = listwsh.Cells(2, 2).Value
listwsh.Cells(rowTitle, colNo).Value = "No"
listwsh.Cells(rowTitle, colPath).Value = "パス"
listwsh.Cells(rowTitle, colFile).Value = "ファイル名"
listwsh.Cells(rowTitle, colPage).Value = "ページ総数"
Call delFileList
'出力行初期化、タイトル行の次から出力
rowCntOutput = rowTitle + 1
'ファイルリストNo.を初期化
cntListNum = 1
Call getFileList(strPath)
listwsh.Select
Set listwsh = Nothing
End Sub
'ファイルリスト取得処理
Sub getFileList(searchpath As String)
Dim listwsh As Worksheet
Dim fso As Object
Dim objFiles As Object
Dim objFolders As Object
Dim separateNum As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set listwsh = ThisWorkbook.Worksheets(strList)
For Each objFolders In fso.GetFolder(searchpath).subfolders
Call getFileList(objFolders.Path)
Next
For Each objFiles In fso.GetFolder(searchpath).Files
separateNum = InStrRev(objFiles.Path, "\")
If (objFiles.Attributes And 4) > 0 Or _
(objFiles.Attributes And 2) > 0 Then
'Systemファイルおよび隠しファイルは処理しない
Else
listwsh.Cells(rowCntOutput, colNo).Value = cntListNum
listwsh.Cells(rowCntOutput, colPath).Value = Left(objFiles.Path, separateNum - 1)
listwsh.Cells(rowCntOutput, colFile).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
Call getFilePage(objFiles.ShortPath)
rowCntOutput = rowCntOutput + 1
cntListNum = cntListNum + 1
End If
Next
'リスト範囲に枠線
listwsh.Range( _
listwsh.Cells(rowTitle, colNo), _
listwsh.Cells(rowCntOutput - 1, colPage)).Borders.LineStyle = True
'リストのタイトル行に色付け
listwsh.Range( _
listwsh.Cells(rowTitle, colNo), _
listwsh.Cells(rowTitle, colPage)).Interior.ColorIndex = 35
'後処理
Set objFiles = Nothing
Set objFolders = Nothing
Set fso = Nothing
Set listwsh = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub getFilePage(strFile As String)
Dim DotPos As Long
Dim PageNum As Variant
Dim strType As String
Dim yenPos As Long
Dim strfname As String
yenPos = InStrRev(strFile, "\")
If yenPos > 0 Then
strfname = LCase(Mid(strFile, yenPos + 1))
End If
PageNum = 0
DotPos = InStrRev(strFile, ".")
If DotPos > 0 Then
strType = LCase(Mid(strFile, DotPos + 1))
If strType = "xlsx" Or _
strType = "xls" Or _
strType = "xlsm" Then
PageNum = getExcelPageNum(strFile)
ElseIf strType = "docx" Or strType = "doc" Then
PageNum = getWordPageNum(strFile)
ElseIf strType = "pdf" Then
'ここを切り替えると他の方のコードと差し替えることが可能
'PageNum = getPdfPageNum(strFile)
PageNum = GetPageNum(strFile)
'「UIAutomationClient」の参照設定が必要
'PageNum = getPdfPageNumProperty(strFile)
Else
'Excel、Word、PDFファイル以外
PageNum = 0
End If
ThisWorkbook.Worksheets(strList).Cells(rowCntOutput, colPage).Value = PageNum
End If
End Sub
Private Function getExcelPageNum(strFile As String) As Variant
Dim wbk As Workbook
Dim workwsh As Worksheet
Dim retVal As Variant
Dim 表示シート数 As Long
'ファイル有無をチェック
Dim chkstr As String
chkstr = Dir(strFile)
If chkstr = "" Then
'ファイルなし
getExcelPageNum = "ファイルなし"
Exit Function
End If
'ファイルを開いているかチェック
Dim chkwsh As worksbook
For Each chkwsh In Workbooks
If chkwsh.Name = chkstr Then
'同名のファイルを開いている
Exit For
Else
Set chkwsh = Nothing
End If
Next
If chkwsh Is Nothing Then
'ファイルを読み取り専用、通知なし、リンク更新なし で開く
Set wbk = Workbooks.Open(Filename:=strFile, notify:=False, UpdateLinks:=0, ReadOnly:=True)
Else
'既に開いているファイルを指定
Set wbk = chkwsh
End If
Set chkwsh = Nothing
'非表示シートを含めたシート数
'retVal = wbk.Worksheets.Count
'表示シートのみのシート数
表示シート数 = 0
For Each workwsh In wbk.Worksheets
If workwsh.Visible Then
表示シート数 = 表示シート数 + 1
Else
'非表示シートをカウントしない
End If
Next
retVal = 表示シート数
getExcelPageNum = retVal
'開いたファイルを保存せずにクローズ
'指定フォルダ以下で開いていたファイルも閉じるので注意
wbk.Close SaveChanges:=False
Set workwsh = Nothing
Set wbk = Nothing
End Function
Private Function getWordPageNum(strFile As String) As Variant
Dim objWord As Object
Dim objDoc As Object
Dim retVal As Long
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(Filename:=strFile, ReadOnly:=True)
retVal = objDoc.Content.Information(4)
objDoc.Close SaveChanges:=False
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
getWordPageNum = retVal
End Function
Private Function getPdfPageNum(strFile As String) As Variant
Dim objPdf As Object
Dim objwork As Object
Dim objResult As Object
Dim xFileNum As Long
Dim xStr As String
Dim retVal As Long
retVal = 0
'Openはパスに環境依存文字が含まれるとエラー
'FSOでバイナリ開けない
'Fso.ShortPathだと環境依存文字が含まれないかも
'vbFormUnicode=128,vbUnicode=64 参照設定しないので直値指定
'VBEはUnicode変換するとShift-JIS以外は"?"となるので環境依存文字判定
Dim temp As String
temp = StrConv(StrConv(strFile, 128, 1041), 64, 1041)
If InStr(temp, "?") <= 0 Then
xFileNum = FreeFile
Open (strFile) For Binary Access Read As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Set objPdf = CreateObject("VBscript.RegExp")
objPdf.Global = True
objPdf.Pattern = "<</Count\s(\d+)"
Set objResult = objPdf.Execute(xStr)
For Each objwork In objResult
getPdfPageNum = objResult.Item(0).SubMatches.Item(0)
Set objPdf = Nothing
Set objwork = Nothing
Set objResult = Nothing
Exit Function
Next
objPdf.Pattern = "/Type\s*/Page[^s]"
Set objResult = objPdf.Execute(xStr)
For Each objwork In objResult
getPdfPageNum = objResult.Count
Set objPdf = Nothing
Set objwork = Nothing
Set objResult = Nothing
Exit Function
Next
Set objPdf = Nothing
Set objwork = Nothing
Set objResult = Nothing
Else
getPdfPageNum = "パスに環境依存文字が含まれています"
Exit Function
End If
getPdfPageNum = "PDFページ取得失敗..."
End Function
' trial ver
' Seiji Fujita rev.2 June 02, 2020 (base code: 'Haluk 19/10/2008)
' Added a file size check to prevent a zero byte file from being created if the file does not exist
' When file does not exit or filesize equal 0, return value = NOTEXIST
' When If it is impossible to count, return value = UNSUPPORTNUM
Function GetPageNum(ByVal PDF_File As String) As Long
Const NOTEXIST As Long = 0
Const UNSUPPORTNUM As Long = -99
Dim FileNum As Long
Dim strRetVal As String
Dim RegExp
Dim nFileLen As Long
Dim getpage0 As Long, getpage1 As Long, getpage2 As Long, _
getpage3 As Long, getpage4 As Long, getpage5 As Long, _
getpage6 As Long, getpage7 As Long
Application.Volatile
' return NOTEXIST when filesize equal zero or file does not exist
On Error Resume Next
nFileLen = FileLen(PDF_File)
On Error GoTo 0
If nFileLen <= 0 Then
GetPageNum = NOTEXIST
Exit Function
End If
FileNum = FreeFile
Open PDF_File For Binary As #FileNum
strRetVal = Space(LOF(FileNum))
Get #FileNum, , strRetVal
Close #FileNum
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
' getpage0 is the basics, but depending on the PDF,
' the number of this pattern differs from the number of pages
RegExp.Pattern = "/Type\s*/Page[^s]"
getpage0 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Resources"
getpage1 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/ProcSet\s*\[/PDF"
getpage2 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Type/Catalog/Page\s*"
getpage3 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/ExtGState"
getpage4 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Type/ObjStm"
getpage5 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Subtype/"
getpage6 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "<rdf:" ' "JFIF" ' "DeviceRGB" ' "/Ordering\(Identity" ' "Registry\(Adobe\)" ' "/BM/Normal"
getpage7 = RegExp.Execute(strRetVal).Count
If getpage0 > 0 Then
GetPageNum = getpage0
Else
If getpage5 > 0 Then
If getpage7 <= 0 Then
GetPageNum = getpage6 - getpage5 - getpage4 - 1
Else
GetPageNum = UNSUPPORTNUM ' cannot get right number; getpage6 - getpage7 - 2 * getpage1 ' not logical, adhoc
End If
Else
GetPageNum = MathMax(MathMax(getpage1, getpage2), getpage3)
' you can use below with MS Excel, insted above
' GetPageNum = Application.WorksheetFunction.Max(getpage1, getpage2, getpage3)
If GetPageNum > getpage4 Then
GetPageNum = GetPageNum - getpage4
End If
End If
End If
End Function
Function MathMax(ByVal a As Long, ByVal b As Long) As Long
If a >= b Then
MathMax = a
Else
MathMax = b
End If
End Function
Private Function getPdfPageNumProperty(PDFPath As String) As Variant
Dim num As Long
num = GetPDFNumPagesUsingAdobeReader(PDFPath)
getPdfPageNumProperty = num
End Function
Private Function GetPDFNumPagesUsingAdobeReader(ByVal PDFPath As String) As Long
'Adobe Readerの[文書のプロパティ]ダイアログからPDFのページ数を取得
Dim uiAuto As CUIAutomation
Dim elmApp As IUIAutomationElement
Dim elmRoot As IUIAutomationElement
Dim elmDialog As IUIAutomationElement
Dim elmTabItem As IUIAutomationElement
Dim elmTextPageNumCaption As IUIAutomationElement
Dim elmTextPageNum As IUIAutomationElement
Dim elmButtonCancel As IUIAutomationElement
Dim elmButtonClose As IUIAutomationElement
Dim ptnSel As IUIAutomationSelectionItemPattern
Dim ptnInvoke As IUIAutomationInvokePattern
Dim hApp As Long
Dim readerPath As String
Dim ret As Long
'Adobe Readerで指定したPDFファイルを表示
readerPath = GetAdobeReaderPath
If Len(Trim(GetAdobeReaderPath)) < 1 Then GoTo Fin
Shell """" & readerPath & """" & " " & """" & PDFPath & """", vbNormalFocus
'Adobe Reader取得
'※PDF表示まで多少時間が掛かる場合有り
Set uiAuto = New CUIAutomation
Set elmRoot = uiAuto.GetRootElement
Do
Set elmApp = GetElement(uiAuto, _
elmRoot, _
UIA_ClassNamePropertyId, _
"AcrobatSDIWindow", _
UIA_WindowControlTypeId)
Sleep 200
DoEvents
Loop While elmApp Is Nothing
'[文書のプロパティ]ダイアログ取得
hApp = elmApp.GetCurrentPropertyValue(UIA_NativeWindowHandlePropertyId)
PostMessage hApp, WM_COMMAND, &H1794, 0 '文書のプロパティ表示
Do
Set elmDialog = GetElement(uiAuto, _
elmApp, _
UIA_NamePropertyId, _
"文書のプロパティ", _
UIA_WindowControlTypeId)
Sleep 200
DoEvents
Loop While elmDialog Is Nothing
'[概要]タブ選択
Set elmTabItem = GetElement(uiAuto, _
elmDialog, _
UIA_NamePropertyId, _
"概要", _
UIA_TabItemControlTypeId)
If elmTabItem Is Nothing Then GoTo Fin
Set ptnSel = elmTabItem.GetCurrentPattern(UIA_SelectionItemPatternId)
ptnSel.Select
'[ページ数]取得
Set elmTextPageNumCaption = GetElement(uiAuto, _
elmDialog, _
UIA_NamePropertyId, _
"ページ数 :", _
UIA_TextControlTypeId)
If elmTextPageNumCaption Is Nothing Then GoTo Fin
Set elmTextPageNum = uiAuto.RawViewWalker.GetNextSiblingElement(elmTextPageNumCaption)
If elmTextPageNum Is Nothing Then GoTo Fin
ret = CLng(elmTextPageNum.CurrentName)
'ダイアログを閉じてアプリケーション終了
Set elmButtonCancel = GetElement(uiAuto, _
elmDialog, _
UIA_NamePropertyId, _
"キャンセル", _
UIA_ButtonControlTypeId)
If elmButtonCancel Is Nothing Then GoTo Fin
Set ptnInvoke = elmButtonCancel.GetCurrentPattern(UIA_InvokePatternId)
ptnInvoke.Invoke
Set elmButtonClose = GetElement(uiAuto, _
elmApp, _
UIA_NamePropertyId, _
"閉じる", _
UIA_ButtonControlTypeId)
If elmButtonClose Is Nothing Then GoTo Fin
Set ptnInvoke = elmButtonClose.GetCurrentPattern(UIA_InvokePatternId)
ptnInvoke.Invoke
Fin:
GetPDFNumPagesUsingAdobeReader = ret
End Function
Private Function GetAdobeReaderPath()
'Adobe Reader(AcroRd32.exe)のパスを取得
Dim folderPath As String
Dim filePath As String
Dim itm As Object
Const ExeName As String = "AcroRd32.exe"
'[プログラムと機能]からAdobe Readerのインストール先フォルダを取得
With CreateObject("Shell.Application").Namespace("shell:::{7b81be6a-ce2b-4676-a29e-eb907a5126c5}")
For Each itm In .Items
If InStr(LCase(itm.Name), "adobe") And InStr(LCase(itm.Name), "reader") Then
'[Extended Asian Language font pack]は除外
If InStr(LCase(itm.Name), "extended") < 1 Then
folderPath = .GetDetailsOf(itm, 10)
Exit For
End If
End If
Next
End With
'Adobe Readerのパスを取得
With CreateObject("Scripting.FileSystemObject")
filePath = .BuildPath(folderPath, "Reader")
filePath = .BuildPath(filePath, ExeName)
If .FileExists(filePath) = True Then GetAdobeReaderPath = filePath
End With
End Function
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