PowerPointに貼り付けまくるVBScript

2008-01-25 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 = "ＭＳ 明朝"
            .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 = "ＭＳ 明朝"
'            .Size = 12
'          End With
'        End With

    Next
    Set myPP = Nothing
    Set fso = Nothing