2013-12-03

PPTで特定の名前を持つShapeを削除する

VBA

Option Explicit
Public Sub CSharpのキーワードの色を変更する()
    Dim keywordList() As String
    keywordList = Split("テキスト", ",")
    Dim keywordColor As Long
    keywordColor = RGB(0, 0, 255)
    
    Dim backGroundColor As Long
    backGroundColor = RGB(128, 0, 128)

    Call DeleteShapesWithName("AutoInserted")

    Dim i As Integer
    For i = LBound(keywordList) To UBound(keywordList)
        Call FindAndChangeColor(keywordList(i), keywordColor, backGroundColor)
    Next
        
End Sub

Sub DeleteShapesWithName(ByVal targetName As String)
    Dim sld As Slide
    Dim shp As Shape
    Dim i As Long
    i = 1
    For Each sld In Application.ActivePresentation.Slides
        Do Until i > sld.Shapes.Count
            If sld.Shapes(i).name = targetName Then
                sld.Shapes(i).Delete
            Else
                i = i + 1
            End If
        Loop
    Next
End Sub

Sub FindAndChangeColor(ByVal keyword As String, ByVal newColor As Long, ByVal newBackGroundColor As Long)
    Dim sld As Slide
    Dim shp As Shape
    Dim txtRng As TextRange
    Dim foundText As TextRange
    Dim foundShape As Shape
    For Each sld In Application.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                Set txtRng = shp.TextFrame.TextRange
                Set foundText = txtRng.Find(FindWhat:=keyword)
                Do While Not (foundText Is Nothing)
                    Set foundShape = sld.Shapes.AddShape( _
                                        msoShapeRectangle, _
                                        foundText.BoundLeft, _
                                        foundText.BoundTop, _
                                        foundText.BoundWidth, _
                                        foundText.BoundHeight)
                    foundShape.Fill.ForeColor.RGB = newBackGroundColor
                    foundShape.Fill.Transparency = 0.8
                    foundShape.name = "AutoInserted"
                    foundShape.Line.Visible = msoFalse

                    With foundText
                        .Font.Color.RGB = newColor
                        Set foundText = _
                            txtRng.Find(FindWhat:=keyword, _
                            After:=.Start + .Length - 1)
                    End With
                Loop
            End If
        Next
    Next
End Sub

2013-10-18

JavaMail

Scala

import java.util.Properties
import java.security.Security
import javax.mail.URLName
import javax.mail.Session
import javax.mail.Store
import javax.mail.Folder
import javax.mail.search.FlagTerm
import javax.mail.Flags
import javax.mail.Message
import javax.mail.NoSuchProviderException
import javax.mail.AuthenticationFailedException
import javax.mail.MessagingException
import com.sun.net.ssl.internal.ssl.Provider

val props = new Properties
Security.addProvider(new Provider)
props.setProperty("mail.pop3.socketFactory.class","javax.net.ssl.SSLSocketFactory")
props.setProperty("mail.pop3.socketFactory.fallback","false")
val protocol = "pop3s"
val urln = new URLName(protocol,
     "pop.gmail.com",
     995,
     null,
     "メールアドレス",
     "パスワード")

val session = Session.getDefaultInstance(props,null)
var store:Store = null
var folder:Folder = null
try {
  store = session.getStore(urln)
  store.connect
  folder = store.getFolder("INBOX")
  folder.open(Folder.READ_WRITE) // 既読Flagの都合上、READ_ONLYではだめ
  val unread = new FlagTerm(new Flags(Flags.Flag.SEEN), false)
  val totalMessages = folder.getMessageCount
  val messages:Array[Message] = folder.search(unread)

  for (msg <- messages) {
    println(msg.getSubject)
    msg.setFlag(Flags.Flag.SEEN, true) // 既読Flagを付ける
  }
  folder.close(false) // DELETEフラグのついてるMessageを削除しないでclose
} catch {
  case e:NoSuchProviderException => e.printStackTrace
  case e:AuthenticationFailedException => e.printStackTrace
  case e:MessagingException => e.printStackTrace
} finally {
  try {
    if (store != null) {
      store.close
    }
  } catch {
    case e:MessagingException => e.printStackTrace
  }
}

2013-10-04

PowerPointのスライドに対し、索引を作成する(1)改

VBA

コマンドラインから実行できるようにした。

' > cscript PPT2Text.vbs powerpoint-filename 
Option Explicit

' ファイル名を実行時パラメータから取得する
Dim pptFilename
pptFilename = WScript.Arguments.Item(0)

Dim oApp
Set oApp = CreateObject("PowerPoint.Application")
oApp.Visible = True

oApp.Presentations.Open(pptFilename)

WScript.echo "<?xml version='1.0' encoding='Shift_JIS' ?>" & vbCrLf
WScript.echo "<Slides>" & vbCrLf

' 全スライドに対して処理を行う
Dim pSlide
For Each pSlide In oApp.ActiveWindow.Parent.Slides
        WScript.echo "<Slide><SlideNumber value='" & pSlide.SlideNumber & "'/>" & vbCrLf
        WScript.echo "<SlideBody><![CDATA[" & vbCrLf
        
        ' スライドのテキストを全部表示する
        Dim pShape
        For Each pShape In pSlide.Shapes
                If pShape.HasTextFrame Then
                        If pShape.TextFrame.HasText Then
                                With pShape.TextFrame.TextRange
                                        WScript.echo CleanChar(.Text)
                                End With
                        End If
                End If
        Next
        
        ' ノートのテキストを全部表示する
        For Each pShape In pSlide.NotesPage.Shapes
                If pShape.HasTextFrame Then
                        If pShape.TextFrame.HasText Then
                                With pShape.TextFrame.TextRange
                                        WScript.echo CleanChar(.Text)
                                End With
                        End If
                End If
        Next
        
        WScript.echo "]]></SlideBody>" & vbCrLf
        WScript.echo "</Slide>" & vbCrLf
Next

WScript.echo "</Slides>"

oApp.ActivePresentation.Application.Quit ' PowerPointを終了する

Set oApp = Nothing


' http://www.tsware.jp/tips/tips_406.htm
' 上記サイトから引用
Private Function CleanChar(ByVal strData)
'引数の文字列から制御コードを除去した文字列を返す

  Dim strRet
  Dim strCurChar
  Dim iintLoop

  strRet = ""
  For iintLoop = 1 To Len(strData)
    strCurChar = Mid(strData, iintLoop, 1)
    If Asc(strCurChar) < 0 Or Asc(strCurChar) >= 32 Then
      '漢字のAscの返り値はマイナスに留意
      strRet = strRet & strCurChar
    End If
  Next

  CleanChar = strRet

End Function

2013-10-04

PPTファイルの索引データを作成する

VBA,Scala

https://github.com/kencoba/PPT2Index

PowerPointファイルの索引データ(キーワードとページ番号リストの対)を
出力するプログラムを作成した。

PPT2Index.bat PowerPointファイルテキストデータ抽出ファイル索引用キーワードファイル

として実行する。

「テキストデータ抽出ファイル」とは、PowerPointファイル中の
スライド、ノートのテキストデータを抜き出したxmlファイルである。
PPT2Indexが作成する中間ファイルである。

「索引用キーワードファイル」は、単に索引として抜き出したい
キーワードを並べたファイル。
以下のような内容である。

- - - - -

オブジェクト
メッセージ
属性
操作
クラス
インスタンス

- - - - -

出力結果は、上記索引用キーワード、タブ、スライド番号リスト(カンマ区切り)
が並んだ形で出力される。
たとえば以下のようになる

- - - - -

オブジェクト 12,13,18
メッセージ 12,13,24
属性 14,15
操作 15
クラス 25
インスタンス 27

- - - - -

2013-10-03

PowerPointのスライドに対し、索引を作成する(2)

Scala

import scala.xml.XML
import scala.xml.Elem
import scala.io.Source

// 索引を付けるPPTファイルから抽出したxml
// <Slides>
//   <Slide>
//     <SlideNumber value="">
//     <SlideBody><!\CDATA[
//       スライドから抽出したテキストデータ
//       スライドノートから抽出したテキストデータ
//     ]]></SlideBody>
//   </Slide>
// </Slides>
val f = new java.io.File("d:\\tmp\\text.pptx.xml")
val xml = XML.loadFile(f)

// 索引用キーワードリスト
val s = Source.fromFile("d:\\tmp\\keywords.txt")
val keywords = try s.getLines.toList finally s.close // 単語のリストを読み込む

// XMLデータを読み込み、キーワードが出てきたページのページ番号リストを返す
def slideNumberList(k:String,xml:Elem):List[Int] = {
  val eachSlide:Seq[Int] = {
    for (s <- xml \ "Slide") yield {
      val target = s \ "SlideBody"
                             
      if (target.text.contains(k)) {
        (s \ "SlideNumber" \ "@value").text.toInt
      } else {
        0
      }
    }
  }
  eachSlide.toList.filter(n => n != 0)
}

// キーワードと番号リストのタプルを一覧で取得する
val index = for (k <- keywords) yield (k,slideNumberList(k,xml))

// 結果表示
for (i <- index) {
  val key = i._1
  val pageNumbers = i._2.mkString(",")
  println(s"${i._1}\t${pageNumbers}")
}

2013-10-03

PowerPointのスライドに対し、索引を作成する(1)

VBA

PPTファイルのスライドの内容を、ノート部分も含めてすべてテキストファイルに出力する

Option Explicit
Sub Extract()

    Dim myFilePath As String
    ' 書き出しファイルを指定する
    myFilePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
               "\" & ActivePresentation.Name & ".xml"

    Open myFilePath For Output As #1

    Print #1, "<?xml version='1.0' encoding='Shift_JIS' ?>" & vbCrLf
    Print #1, "<Slides>" & vbCrLf

    Dim pSlide As slide
        
    For Each pSlide In ActiveWindow.Parent.Slides
        Print #1, "<Slide><SlideNumber value='" & pSlide.SlideNumber & "'/>" & vbCrLf
        Print #1, "<SlideBody><![CDATA[" & vbCrLf
        
        ' スライドのテキストを全部表示する
        Dim pShape As Shape
        For Each pShape In pSlide.Shapes
            If pShape.HasTextFrame Then
                If pShape.TextFrame.HasText Then
                    With pShape.TextFrame.TextRange
                        Print #1, CleanChar(.Text)
                    End With
                End If
            End If
        Next
        
        ' ノートのテキストを全部表示する
        For Each pShape In pSlide.NotesPage.Shapes
            If pShape.HasTextFrame Then
                If pShape.TextFrame.HasText Then
                    With pShape.TextFrame.TextRange
                        Print #1, CleanChar(.Text)
                    End With
                End If
            End If
        Next
    
        Print #1, "]]></SlideBody>" & vbCrLf
        Print #1, "</Slide>" & vbCrLf
    Next

    Print #1, "</Slides>"

    Close #1

End Sub

' http://www.tsware.jp/tips/tips_406.htm
' 上記サイトから引用
Private Function CleanChar(strData As String) As String
'引数の文字列から制御コードを除去した文字列を返す

  Dim strRet As String
  Dim strCurChar As String
  Dim iintLoop As Integer

  strRet = ""
  For iintLoop = 1 To Len(strData)
    strCurChar = Mid$(strData, iintLoop, 1)
    If Asc(strCurChar) < 0 Or Asc(strCurChar) >= 32 Then
      '漢字のAscの返り値はマイナスに留意
      strRet = strRet & strCurChar
    End If
  Next iintLoop

  CleanChar = strRet

End Function

2013-09-27

セル内の文字列の改行操作

VBA

Excelシートにアンケートコメントを格納した場合、
印刷時に最後の行が表示されなくなることがあります。
PC画面上では見えているのに、印刷では見えない。

対策としては、「各セルの文字列の最後に改行を入れる」
というのがありますが、非常に煩雑です。
手作業でやるもんじゃありません。

' 文章の最後に空行を追加する
Sub InsertLastNewline()
    Dim c As Range
    For Each c In Selection
        If Right(Trim(c.Value), 1) <> Chr(10) Then
            c.Value = c.Value & Chr(10)
        End If
    Next c
End Sub

'セル内のすべての改行を削除するサブルーチン
Sub DeleteNewlines()
    Dim c As Range
    For Each c In Selection
        If Right(Trim(c.Value), 1) = Chr(10) Then
            c.Value = WorksheetFunction.Substitute(Trim(c.Value), Chr(10), "")
        End If
    Next c
End Sub

' DeleteNewLinesでは、文章途中の改行まで全部削除してしまう
' このサブルーチンは、最後の改行のみ削除する
Sub DeleteLastNewlines()
    Dim c As Range
    For Each c In Selection
        Do While Right(Trim(c.Value), 1) = Chr(10)
            c.Value = Left(c.Value, Len(c.Value) - 1)
        Loop
    Next c
End Sub