PowerPointに貼り付けまくるVBScript
徐々に、っていうか、かなり毎日VBScriptをいじって。
トリアエズ、近々の作業で必要な物は作った。
すごいね、PowerPoint!改めて感動。
パワポ上のオブジェクト(?テキストボックスとか、画像とか、線とか)は、全部プログラムから制御可能。
繋がっている、オブジェクトを調べるとかもできる。
ただ、PowerPoint VBAとかVBScriptに関する書物が少ないので、
MSDNのページとGoogle先生でひたすら調べながら作るという非効率さ・・・
だれか、その手の本を書けば良いのに・・・
Office製品のオブジェクトとかVBAとかを改めて勉強したくなった、
けど、そんな暇ねー
細かい説明はまた今度しますが、ソースを張っておきます。
スパゲッティーというか、あっちコッチのスクリプトを足して貼り付けて、
ナントカ動くというレベルの物です。
きっとこびとさんが直してくれるはず・・・・
GetAllCapture.vbs
Option Explicit Private FSO Private SourcePath Private CapturePath,TempPath Private ThisFolder Private f Private WshShell Dim WSH,wExec '■必要なパラメータは↓ここで調整 SourcePath = "C:\test\testdir" 'ここにHTMLソースを置く CapturePath = "C:\test\capture" 'ここにJPEGが出力される。 TempPath = "C:\test\temp" 'ここにTEMPファイルが出力される。 '■出力ディレクトリが合ったらエラーで終了。無いときは作る。 ' なぜなら、その後の処理で中身を全部消してしまうから。 Set FSO = CreateObject("Scripting.FileSystemObject") if FSO.FolderExists(CapturePath) then MsgBox CapturePath & "フォルダが存在するため処理を終了します。" WScript.Quit 1 ELSE FSO.CreateFolder CapturePath End if '■フォルダコピー Set ThisFolder = FSO.GetFolder(SourcePath) ThisFolder.Copy CapturePath & "\", True Set FSO = Nothing Set ThisFolder = Nothing '■HTMLのファイルリストを取得 Set WSH = CreateObject("WScript.Shell") Set wExec = WSH.Exec("%ComSpec% /c ""dir " & SourcePath & "\*.htm* /b/a-d/s > " & TempPath & "\HtmList.txt""") Set wExec = Nothing Set WSH = Nothing '■悪いけどディレクトリの中身は消えていただきます。 'キャプチャー出力ファイルの実行予定一覧取得 Set WSH = CreateObject("WScript.Shell") Set wExec = WSH.Exec("%ComSpec% /c ""dir " & CapturePath & "\*.htm* /b/a-d/s > " & TempPath & "\CapList.txt""") Set wExec = Nothing Set WSH = Nothing 'キャプチャーディレクトリの中身の削除対象リスト取得 Set WSH = CreateObject("WScript.Shell") Set wExec = WSH.Exec("%ComSpec% /c ""dir " & CapturePath & "\* /b/a-d/s > " & TempPath & "\DelList.txt""") Set wExec = Nothing Set WSH = Nothing MsgBox CapturePath & "ディレクトリリストを取得しました。" 'ここでWaitを入れないと、DelListができあがらないうちに次の処理が走るとエラーになる。 'ループしてファイル削除 '★ ファイルの存在と書き込みできるか確認を入れる。 Private FileName Private i Set FSO = CreateObject("Scripting.FileSystemObject") With FSO.OpenTextFile(TempPath & "\DelList.txt") While Not .AtEndOfStream i = i + 1 'WScript.Echo i & .ReadLine FSO.DeleteFile .ReadLine Wend .Close End With Set FSO = Nothing '■そのファイルごとに出力を掛けるループ '取得元ファイル名を取り出す Private SourceFile(99999) i = 0 Set FSO = CreateObject("Scripting.FileSystemObject") With FSO.OpenTextFile(TempPath & "\HtmList.txt") While Not .AtEndOfStream i = i + 1 SourceFile(i) = .ReadLine Wend .Close End With Set FSO = Nothing '保存先ファイル名を取り出す Private CaptureFile(99999) i = 0 Set FSO = CreateObject("Scripting.FileSystemObject") With FSO.OpenTextFile(TempPath & "\CapList.txt") While Not .AtEndOfStream i = i + 1 CaptureFile(i) = .ReadLine Wend .Close End With Set FSO = Nothing 'バッチファイルでも出力するか? Private j Set FSO = CreateObject("Scripting.FileSystemObject") With FSO.CreateTextFile(TempPath & "\AllCap.bat",True,False) For J = 1 to i '★一応中身確認しようか、ドッチかがが空だったらエラーにしよう .WriteLine "c:\crena\CrenaHtml2jpg.exe -o"""& CaptureFile(j) &".jpg"" -fjpeg -w240x1200 -s240x1200 -q80 -t25 -u""" & SourceFile(j) Next .Close End With Set FSO = Nothing 'バッチファイルを叩く。 Set WshShell = CreateObject("WScript.Shell") WshShell.Run TempPath & "\AllCap.bat ",1,true Set WshShell = Nothing '終わり
AllAttachPPT.vbs
Option Explicit Private FSO Private SourcePath,CapturePath,TempPath Private f,i '■必要なパラメータは↓ここで調整 SourcePath = "C:\test\testdir" 'ここにHTMLソースを置く CapturePath = "C:\test\capture" 'ここにJPEGが出力される。 TempPath = "C:\test\temp" 'ここにTEMPファイルが出力される。 '保存先ファイル名を取り出す Private CaptureFile(99999) i = 0 Set FSO = CreateObject("Scripting.FileSystemObject") With FSO.OpenTextFile(TempPath & "\CapList.txt") While Not .AtEndOfStream i = i + 1 CaptureFile(i) = .ReadLine Wend .Close End With Set FSO = Nothing '取得元ファイル名を取り出す Private SourceFile(99999) i = 0 Set FSO = CreateObject("Scripting.FileSystemObject") With FSO.OpenTextFile(TempPath & "\HtmList.txt") While Not .AtEndOfStream i = i + 1 SourceFile(i) = .ReadLine Wend .Close End With Set FSO = Nothing Dim myPpt Dim ppAp Dim myPP, mySd Dim myH, myW Dim h, y, Flg Dim PPTextBox Private j Private FileName , Buffer , Buffer_text , Buffer_title 'PPTオブジェクト定義 Set ppAp = CreateObject("PowerPoint.Application") ppAp.WindowState = 1 Set myPP = ppAp.Presentations.Add With myPP.SlideMaster myH = 420 myW = 173 End With For J = 1 to i Set FSO = CreateObject("Scripting.FileSystemObject") FileName = SourceFile(J) With FSO.OpenTextFile(FileName) Buffer = .ReadAll .Close End With '読み込んだファイル(=Buffer)からタグを取り除く With New RegExp .Global = True .Pattern = "(<[^>]+>)" Buffer_text = .Replace(Buffer, "") ' 空行を詰めたいが、なんかうまくいかないっす。 .Pattern = "\r\n\r\n" Buffer_text = .Replace(Buffer_text, Chr(13)) End With '読み込んだファイル(=Buffer)からタイトルを抽出 ' With New RegExp ' .Global = True ' .Pattern = "(<[^>]+>)" ' Buffer_text = .Replace(Buffer, "") ' 空行を詰めたいが、なんかうまくいかないっす。 ' .Pattern = "^\n$" ' Buffer_text = .Replace(Buffer_text, "") ' End With '画像を追加 Set mySd = myPP.Slides.Add(J, 1) myPP.Slides.Range(J).Shapes.AddPicture CaptureFile(J) & ".jpg", False, True, 10, 40, myW, myH 'テキストを追加 Set PPTextBox = myPP.Slides.Range(J).Shapes.AddTextbox(1, 200.0, 40.0, 233.0, 28.0) PPTextBox.TextFrame.WordWrap = True With PPTextBox.TextFrame.TextRange .Text = Buffer_text With .Font .NameFarEast = "MS 明朝" .Size = 12 End With End With ' 'タイトルを追加 タイトルに出来ないが、テキストボックスで追加 作成中 ' Set PPTextBox = myPP.Slides.Range(J).Shapes.AddTextbox(1, 200.0, 40.0, 233.0, 28.0) ' PPTextBox.TextFrame.WordWrap = True ' With PPTextBox.TextFrame.TextRange ' .Text = Buffer_title ' With .Font ' .NameFarEast = "MS 明朝" ' .Size = 12 ' End With ' End With Next Set myPP = Nothing Set fso = Nothing
■使い方
・上記のソースをc:\test\にそれぞれ保存
・c:\crenaにダウンロードしたスクリプトを配置。
・c:\test\testdir にHTMLファイルを置き
GetAllCapture.vbsを実行すると、
c:\capture配下に、testdirと同じディレクトリ構造で、
*.html.jpgというファイルを吐きまくる。
上記のスクリプトを実行後、PPTを開いて
AllAttachPPT.vbsを実行
c:\capture以下のjpegを貼り付けて、
ソースファイルのタグ以外の部分を貼り付けます。
これで、携帯の遷移図っていうか、仕様書を書くのに
スゲー楽になるはず。
CrenaHtml2jpg WEBページをサムネイル画像にするexe
http://dip.picolix.jp/disp5.html