foobar2000の日付時刻データをDate型の値に変換する

foobar2000の日付時刻データをDate型の値に変換する

Date型の値を、foobar2000独自の日付時刻文字列に変換するのは

akashi-keirin.hatenablog.com

で作成済み。

今度は、その逆をやってみる。

考え方

foobar2000のPlayback Statisticsでは、再生日時を18ケタの数字で表現している。

そのうち、整数秒までの表現で良いのなら、下7ケタは無視してもよい。

上11ケタが秒単位で表された日時である。

そして、たとえば2012年1月1日 0:00:00が12969817200であることはわかっている。

したがって、foobar2000独自の日付時刻文字列(めんどくさいので、以下「日時コード」という。)を求めるには、

  1. 当該の日時コードと基準日の日時コードとの差を求める
  2. 上記1.を8640024 * 60 * 60)で割る
  3. 上記2.で得た数が基準日からの日数差なので、基準日に加算する
  4. 上記3.で得た値が年月日
  5. 上記2.で得た余りを3600(60 * 60)で割る
  6. 上記5.で得た商が時
  7. 上記5.で得た余りを60で割る
  8. 上記7.で得た商が分
  9. 上記7.で得た余りが秒

まあ、比較的簡単に求めることができる。

必要な値の特定

日時コードは最大3種類(「FirstPlayed」「LastPlayed」「Added」)あり、それぞれの要素が必ず書き込まれているとは限らないので、XMLの要素の中のどの部分が対象の日時コードであるのかは一意に決まっていない。

そこで、XML要素の中から対象の日時コードを引っ張ってくるFunctionが必要である。ただ、幸い日時コードは18文字であることが決まっているので、対象の日時コードの先頭位置さえわかれば、抜き出すことはわけもなくできる。

コーディング

……というわけで、コーディング。

まずは、XML要素の中から、対象の日時コードを引っ張ってくるFunction。

リスト1 標準モジュール宣言セクション
'Constants'
Public Enum DateMode  '……(1)'
  [_ddStart] = 3
    dmFirstPlayed = [_ddStart]
    dmLastPlayed = dmFirstPlayed + 2
    dmAdded = dmLastPlayed + 2
End Enum

'2012年1月1日 0時00分00秒の日付時刻値の上11桁'
Private Const STANDARD_DATE_VALUE As Currency = 12969817200#
Private Const STANDARD_DATE As Date = "2012/1/1"
'一日あたりの秒数'
Private Const DAY_BY_SECONDS As Currency = 86400

(1)からの6行では、Enumの宣言をするのに、id:x1xy2xyz3 さんに教えてもらったテクニックを早速使ってみた。

メンバの値を「3」、「5」、「7」にしているのには一応意味があるんだが、今回は関係ないので説明は省く。

後半の定数群は、コメントで記したとおり。変換計算をするときに必要な値なので、定数化しているだけ。

スト2 標準モジュール

お次は対象の日時コードを抜き出すFunction。

Public Function getDateTimeCodeFromElement( _
            ByVal targetElement As String, _
            ByVal targetMode As DateMode) As String  '……(2)'
  Dim ret As String
  ret = ""
  Dim modeStr As String
  Select Case targetMode  '……(3)'
    Case dmFirstPlayed: modeStr = "FirstPlayed="""
    Case dmLastPlayed: modeStr = "LastPlayed="""
    Case dmAdded: modeStr = "Added="""
  End Select
  Dim startPos As Long
  startPos = InStr(1, targetElement, modeStr)  '……(4)'
  If startPos = 0 Then GoTo Finalizer  '……(5)'
  startPos = startPos + Len(modeStr)  '……(6)'
  ret = Mid(targetElement, startPos, 18)  '……(7)'
Finalizer:
  getDateTimeCodeFromElement = ret
End Function

まず(2)の

Public Function getDateTimeCodeFromElement( _
            ByVal targetElement As String, _
            ByVal targetMode As DateMode) As String

で引数設定。

第1引数targetElementで、XMLの要素文字列を受け取る。

ちなみに、XML要素文字列は、全ての内容が書き込まれていると

  <Entry ID="f1a6d9d835f110fa" Count="2" FirstPlayed="129945499660000000" LastPlayed="131972743430000000" Added="131907872960000000" />

こんなクソ長ったらしいものである。

第2引数は、リスト1で設定した列挙体DateMode型。どの日時コードを抜き出すのかを指定するのに使う。

(3)からの5行

Select Case targetMode
  Case dmFirstPlayed: modeStr = "FirstPlayed="""
  Case dmLastPlayed: modeStr = "LastPlayed="""
  Case dmAdded: modeStr = "Added="""
End Select

で、対象の日時コードを探すためのキーとなる文字列を変数targetModeにセットする。

FirstPlayed」だけでなく、「FirstPlayed="」までをキーにしているのには意味がある。後述する。

(4)の

startPos = InStr(1, targetElement, modeStr)

で、まず「FirstPlayed="」、「LastPlayed="」、「Added="」を検索し、XML要素の何文字目の位置に出てくるのかを割り出す。

この段階で変数startPosにぶち込まれるのは、たとえば「FirstPlayed="」の先頭の「F」の位置に過ぎない。

(5)の

If startPos = 0 Then GoTo Finalizer

はガード節。この段階でstartPos0だということは、対象の日時が設定されていないということなので、ここで処理を打ち切る。

(5)をくぐり抜けたということは、対象の日時が設定されているということになるので次へ進む。

(6)の

startPos = startPos + Len(modeStr)

で日時コードの先頭位置を割り出すことができる。

たとえば、「FirstPlayed」の場合、先頭の「F」が20文字目に出てくるとすると、「FirstPlayed="」が13文字あるので、startPosの値は「33」。

先頭から33文字目というのは、「FirstPlayed="」のすぐ次の位置なのである。

日時コードは18文字と決まっているので、あとは(7)の

ret = Mid(targetElement, startPos, 18)

で先頭位置から18文字分切り出してやればよい。

これで、日時コードを抜き出すことができる。

リスト3 標準モジュール

そして、日時コードをDate型の値に変換するFunction。

Public Function getDateTime( _
            ByVal dateCode As String) As Date
  Dim ret As Date
  '上11ケタを切り出す'
  Dim tmpCode As String
  tmpCode = Left(dateCode, 11)
  '基準日の値との差を求める'
  Dim tmpCurr As Currency
  tmpCurr = CCur(tmpCode)
  Dim dateDiff As Currency
  dateDiff = tmpCurr - STANDARD_DATE_VALUE
  '日数差を求める'
  Dim tmpDay As Currency
  tmpDay = dateDiff \ DAY_BY_SECONDS
  '日数差を元に日付を求める'
  Dim tmpDate As Date
  tmpDate = tmpDay + STANDARD_DATE
  ret = tmpDate
  '時刻を求める'
  Dim tmpTime As Currency
  tmpTime = dateDiff Mod DAY_BY_SECONDS
  Dim tmpHour As Long
  tmpHour = tmpTime \ 3600
  Dim tmpMinute As Long
  tmpMinute = (tmpTime Mod 3600) \ 60
  Dim tmpSecond As Long
  tmpSecond = ((tmpTime Mod 3600) Mod 60)
  '日付と時刻を合成する'
  ret = tmpDate + TimeSerial(tmpHour, tmpMinute, tmpSecond)
  getDateTime = ret
End Function

まあ、コード中のコメントを見たら、何をやっているのかはわかると思う。

使ってみる

上で挙げた

  <Entry ID="f1a6d9d835f110fa" Count="2" FirstPlayed="129945499660000000" LastPlayed="131972743430000000" Added="131907872960000000" />

FirstPlayedの日時コード「129945499660000000」がいつのことを表すのか、調べてみる。

ちなみに、このXMLの元になった曲データは

f:id:akashi_keirin:20190326170215j:plain

こいつのもの。

FirstPlayedは、「2012-10-13 06:12:46」である。

イミディエイト・ウインドウに、

?getDateTime(getDateTimeCodeFromElement("  <entry count="" added="" lastplayed="" firstplayed="" f1a6d9d835f110fa="" 131907872960000000="" 131972743430000000="" 129945499660000000="" 2="">",dmFirstPlayed))

と打ち込んで、[Enter]。

f:id:akashi_keirin:20190326170219j:plain

うむ。バッチリ。

おわりに

で、何に使うんでしょう???

Enumの研究(3)

Enumの研究(3)

こいつら

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

の続き。

今回はちょっと手の込んだことをする。

組み込みプロパティ名と衝突した場合のち~んw珍現象

まず、Sheet1に次のような表を作成しておく。

f:id:akashi_keirin:20190324162940j:plain

次に、Sheet1モジュールに次のコードを書く。

リスト1 Sheet1モジュール
Public Property Get HogeValue(ByVal index As Hoge) As String
  If index = Name Then HogeValue = "Hoge": Exit Property
  HogeValue = Me.Range("A1").CurrentRegion.Item(index)
End Property

そして、EnumHoge」は次のようにしておく。

スト2 標準モジュール宣言セクション
Public Enum Hoge
  Name = 0
  hgFirstElement = 2
  hgSecondElement
  hgThirdElement
  hgFourthElement
  hgFifthElement
End Enum

実は、リスト2の入力中、

If index =

まで入力すると、

f:id:akashi_keirin:20190324163000j:plain

このように、クイックヒントが出る。プロパティ「HogeValue」の引数がHoge型なのだから、当り前なのだが、とにかく、VBEの指示通りに入力すると、この行は

If index = Name Then HogeValue = "Hoge": Exit Property

となるのである。

使ってみる

さっそく、Sheet1オブジェクトのHogeValueプロパティを利用するコードを書いて実行してみる。

リスト3 標準モジュール
Public Sub test03()
  Debug.Print Sheet1.HogeValue(Name)
End Sub

こいつをステップ実行してみる。

f:id:akashi_keirin:20190324162945j:plain

引数Nameのところにマウスを当てると、「0」がポップアップする。

この時点では、「Name」は「0」と解釈されている。

この行を実行すると、処理がSheet1Property Get HogeValueプロシージャに移る。

f:id:akashi_keirin:20190324162948j:plain

index」のところにマウスを当てると、「「0」がポップアップするので、引数「index」はちゃんと「0」を受け取っている。当たり前だが。

さらに1行処理を進める。すると、

f:id:akashi_keirin:20190324162953j:plain

あっ。ここで「Name」にマウスを当てると、「Sheet1」がポップアップする。

すなわち、Sheet1モジュール内では「Name」はEnumHoge」のメンバではなく、Sheet1オブジェクトのメンバと評価されてしまうようだ。

当然、そのまま実行すると、

f:id:akashi_keirin:20190324162957j:plain

こうなる。

おわりに

リスト1

If index = Name Then HogeValue = "Hoge": Exit Property

を、

If index = Hoge.Name Then HogeValue = "Hoge": Exit Property

とすれば意図どおりに動作する。

いづれにせよ、やはり組み込みプロパティをEnumの要素名に使うのはやめた方がいい。

Enumの研究(2)

Enumの研究(2)

前回

akashi-keirin.hatenablog.com

の続き。しつこくEnumを追究することにする。

組み込みプロパティ名との衝突

たとえば、EnumHoge」に「Name」という要素を持たせてみる。

リスト1 標準モジュール宣言セクション
Public Enum Hoge
  Name = 0
  hgFirstElement = 2
  hgSecondElement
  hgThirdElement
  hgFourthElement
  hgFifthElement
End Enum

EnumHoge」に新しい仲間「Name」を加えた。

さっそく使ってみる。

イミディエイト・ウインドウに

?Name

と打ち込んで[Enter]。

f:id:akashi_keirin:20190324153953j:plain

何ごともなく、Enumのメンバとして仕事をしている。

どうやら、Enumの要素名に組み込みのプロパティ名を用いても問題ないようだ。

ちょっと待て。

実は、問題が生ずる場面があることを私は知っている。

例えば、次のコードをシートモジュールで実行するとどうなるか。

スト2 Sheet1モジュール
Public Sub test01()
  Debug.Print Name
End Sub

これと全く同じコードを標準モジュールに書いて実行すると、イミディエイト・ウインドウには、

f:id:akashi_keirin:20190324153956j:plain

このように出力されるのである。

しかし、シートモジュールに書いて実行すると、

f:id:akashi_keirin:20190324153959j:plain

このように、「Sheet1」と、シート名が表示される。

つまり、「Name」はEnumHoge」のメンバではなく、Sheet1オブジェクトのプロパティとして働いたということになる。

これは、ThisWorkbookモジュールに書いた場合も同じで、ThisWorkbookモジュールの場合はブック名が返ることになる。

ここまでのまとめ

上記のように、使う場面によって働きが異なる、というのは非常に危険なので、組み込みのプロパティ名も使わない方が無難だろう。

ちなみに、Nameプロパティの場合だとString型の返り値なので、エラーが出ずに結果が出力されるが、たとえばAutoFilgerのようなオブジェクト型のプロパティだとどうなるか。

次のようにして実験してみる。

リスト3 標準モジュール宣言セクション
Public Enum Hoge
  Name = 0
  AutoFilter = 1
  hgFirstElement = 2
  hgSecondElement
  hgThirdElement
  hgFourthElement
  hgFifthElement
End Enum
リスト4 Sheet1モジュール
Public Sub test01()
  Debug.Print Name
  Debug.Print AutoFilter
End Sub

これを実行すると、シートにオートフィルターが設定されていないときは、

f:id:akashi_keirin:20190324154003j:plain

シートにオートフィルターを設定しておくと、

f:id:akashi_keirin:20190324154006j:plain

それぞれこんなエラーが出た。

もちろん、

Debug.Print Hoge.AutoFilter

なら、エラーは出ずに「1」が出力される。

おわりに

やはり、組み込みのプロパティ名との衝突も避けた方が良いみたい。

Enumの研究(1)

Enumの研究(1)

コードの可読性を上げる一つの方法として、

Enumを適切に使う

というものがある。

ずいぶん前からEnum自体は使っていたが、最近やっと適切な使い方が定まってきたように思うので、Enumについていろいろ実験したことを書き留めておく。

Enumの要素名がuniqueであるとき

長らく勘違いしていたのだが、Enumの要素名がuniqueである場合、定数のように単独で使うことができる。

なんでこんな簡単なことに気付かなかったのかというと、入門書とかに「xlContinuous」の類のことが、

組み込み定数

と書いてあるのが原因だと思う。

Microsoftのリファレンスを検索したら、たとえば先の「xlContinuous」の場合、「XlLinStyle列挙体」とちゃんと書いてある。

xlContinuous」を「XlLineStyle.xlContinuous」と書かなくてもよいのだから、自作のEnumだって要素名だけで定数のように使えるのは当り前なのだ。

リスト1 標準モジュール宣言セクション
Public Enum Hoge
  firstElement = 2
  secondElement
  thirdElement
  fourthElement
  fifthElement
End Enum

たとえば、このようにEnumを作る。

で、イミディエイト・ウインドウに

?firstElement

と打ち込んで、[Enter]を押すと、

f:id:akashi_keirin:20190324145646j:plain

このように、「2」が出力される。

ちゃんと、「2」を意味する定数として働いていることがわかる。

Enumの要素名が衝突しているとき

では、Enumの要素名が他のEnumの要素名と衝突していたらどうなるのだろうか。

スト2 標準モジュール宣言セクション
Public Enum Hoge
  firstElement = 2
  secondElement
  thirdElement
  fourthElement
  fifthElement
End Enum

Public Enum Foobar
  firstElement = 3
  secondElement
  thirdElement
  fourthElement
  fifthElement
End Enum

ご覧のように、新しいEnumFoobar」を作成し、先の「Hoge」とほぼ同じ要素を持たせてみる。

このようにした上で、イミディエイト・ウインドウに先ほどと同じく

?firstElement

と打ち込んで[Enter]。

f:id:akashi_keirin:20190324145649j:plain

firstElement」だけでは、EnumHoge」の「firstElement」なんだかEnumFoobar」の「firstElement」なんだか、コードを打ち込んだ本人にもわからないのだから、当然こうなる。

もちろん、たとえば

?Foobar.firstElement

としてやれば、

f:id:akashi_keirin:20190324145654j:plain

このように意図したとおりの結果は得られる。しかし、いちいちEnum名を指定しないといけないのではめんどくさいことこの上ない。

ひとまずのまとめ

ここまでをまとめると、

Enumの要素名はuniqueにすべし!

ということになる。

要素名の衝突を防ぐために、本家Microsoft Officeシリーズでは、

要素名に接頭辞を付ける

という対策をとっている。

これを真似しない手はない。

そこで、最近は、

要素名の先頭にEnum名の略語を添える

というやり方をしている。

たとえば、先のEnumHoge」、「Foobar」なら、次のようにするのである。

リスト3 標準モジュール宣言セクション
Public Enum Hoge
  hgFirstElement = 2
  hgSecondElement
  hgThirdElement
  hgFourthElement
  hgFifthElement
End Enum

Public Enum Foobar
  fbFirstElement = 3
  fbSecondElement
  fbThirdElement
  fbFourthElement
  fbFifthElement
End Enum

これだけのことで、uniqueなEnum要素名が作りやすくなる。

今回はアホみたいなEnum名なので実感しにくいが、Enum名を役割明示的にして、略語もわかりやすいものにしておけば、コーディングが非常に楽になる。

おわりに

過去に書いたコードを見直してみて、Enumの使い方が我ながらめちゃくちゃだったので、書いてみました。

お役に立てれば幸いです。

「Any型」の追放に成功した

Any型の追放に成功した

akashi-keirin.hatenablog.com

これの続報。

この記事には、id:imihito さんからコメントをいただいていた。

曰く、

記事の
`Call MoveMemory(lpMemory, VarPtr(strText), lngSize)`
に関しては`VatPtr`を`StrPtr`にするとどうなるでしょうか?

と。

そもそもStrPtrというものを知らなかった。

で、やってみた。

API関数の宣言部の書き換え

問題のAPI関数は、次のもの。

Private Declare Sub MoveMemory Lib "kernel32" _
                      Alias "RtlMoveMemory" _
                      (ByVal lpDest As Any, _
                       ByVal lpSource As Any, _
                       ByVal Length As Long)

メモリの書き込み先と、書き込み元のメモリアドレスの指定っぽい第1・2引数がナゾのAny型指定になっている。こいつらを、Long型に変える。

Private Declare Sub MoveMemory Lib "kernel32" _
                      Alias "RtlMoveMemory" _
                      (ByVal lpDest As Long, _
                       ByVal lpSource As Long, _
                       ByVal Length As Long)

呼び出し側コードの修正

そして、ClipboardクラスのsetTextgetTextメソッド内で、MoveMemory関数を呼び出している部分のコードを修正する。

リスト1 クラスモジュール
'setTextメソッド内'
Call MoveMemory(lpDest:=pointerOfMemory, _
                lpSource:=StrPtr(targetText), _
                Length:=sizeOfText)

第2引数lpSourceString型の変数targetTextを渡していたのを、StrPtr(targetText)に改めた。

スト2 クラスモジュール
'getTextメソッド内'
Call MoveMemory(lpDest:=StrPtr(targetText), _
                lpSource:=pointerOfMemory, _
                Length:=sizeOfText)

こちらは、

第1引数lpDestString型の変数targetTextを渡していたのを、StrPtr(targetText)に改めた。

いづれも、Any型指定でString型引数を渡していたのをLong型に改めたことになる。

実行

次のコードで実行。

リスト3 標準モジュール
Public Sub test()
  Dim clpBoard As New Clipboard
  With clpBoard
    Call .setText("ち~んw")
    Debug.Print .getText
  End With
End Sub

Clipboardクラスのインスタンスを作成し、setTextメソッドによってクリップボードに「ち~んw」と書き込み、getTextメソッドでその「ち~んw」を取り出してイミディエイト・ウインドウに出力するだけのコード。

実行結果

f:id:akashi_keirin:20190323095949j:plain

おお! 動いた!

おわりに

ちなみに、StrPtrではなく、VarPtrにすると、

f:id:akashi_keirin:20190323095952j:plain

このようにエラーとなり、そのまま終了すると、クリップボードが使えなくなる。

StrPtrに戻して一度実行すると復活しましたが、ヒヤリとしましたw

ファイル名が重複するときに自動ナンバリングする

ファイル名が重複しているときに自動ナンバリングしたファイル名を返すメソッド

頭の体操に作ってみた。

ExportAsFixedFormatメソッドで新規ファイルを作成したときなんかに、同一名のファイルが存在したときの対策用。

たとえば、保存先に「ち~んw.pdf」というファイルを保存しようとしたときに、既に同一名のファイルが存在した場合、「ち~んw(1).pdf」、「ち~んw(2).pdf」……といった具合に新たなファイル名にして保存するために、ナンバリングしたファイル名を返す、というふうにしたい。

コーディング

書いたコードは次の通り。

リスト1 標準モジュール
Public Function getNameWithoutDuplication( _
            ByVal fullNameWithoutFilebase As String, _
            ByVal fileBaseName As String) As String  '……(1)'
  Dim tmp As String  '……(2)'
  tmp = fullNameWithoutFilebase
  Dim n As Long  '……(3)'
  n = 0
  Dim fsObj As New FileSystemObject  '……(4)'
  Dim suffixStr As String
  Do While fsObj.FileExists(tmp & suffixStr & "." & fileBase)
    n = n + 1
    suffixStr = "(" & n & ")"
  Loop
  getNameWithoutDuplication = tmp & suffixStr & "." & fileBase
End Function

(1)の

Public Function getNameWithoutDuplication( _
            ByVal fullNameWithoutFilebase As String, _
            ByVal fileBaseName As String) As String

は引数、返り値設定。

〈拡張子を除いたファイルのフルパス〉というのは、後で見たときにわかりにくかろうと思うので、冗長な引数名にした。

拡張子を除いた新規ファイルのファイルフルパス、新規ファイルの拡張子名を受け取って、重複がある場合はナンバリングを付して拡張子も加えたファイル名、つまりはファイルのフルパスを返すメソッド。

(2)からの2行

Dim tmp As String
tmp = fullNameWithoutFilebase

は、別になくても構わないのだけれど、引数名が長すぎるので、一旦tmpで受け取る。

10行程度の短いメソッドなので、まあ許されるだろう、と。

3からの8行

Dim n As Long
n = 0
Dim fsObj As New FileSystemObject  '……(4)'
Dim suffixStr As String
Do While fsObj.FileExists(tmp & suffixStr & "." & fileBase)
  n = n + 1
  suffixStr = "(" & n & ")"
Loop

がメインの処理。

変数nは、ナンバリング用の変数。使用済みの番号があったら、ループ内でインクリメントする。

必要ないけれど、明示的に初期化しておく。

(4)の

Dim fsObj As New FileSystemObject

FileSystemObjectインスタンスを準備。ループ内でファイルの存否確認に使う。

Dir関数を使う手もあるけれど、今はFileSystemObjectの練習中だということと、FileSystemObjectを使った方がreadableになるような気がするので、積極的に使う。

事前バインディングのコードなので、参照設定を忘れずに。

ループ処理もついでに見ておこう。

ループへの突入条件は

Do While fsObj.FileExists(tmp & suffixStr & "." & fileBase)

このとおり。

readableと述べたのはまさにこのことで、「カッコ内に示したファイルが存在する間はやれ!」とそのまま読める。

Do While Dir(hogehoge) <> ""

では、直感的に何のことかわからないので、イマイチだと思うようになった。

tmp & suffixStr & "." & fileBase」がそもそも付けんと欲したファイル名なので、このファイルが存在しないならばナンバリングの必要はない。従って、ループに突入する必要などないわけだ。

ループに突入するということは、ナンバリングが必要だということなので、

n = n + 1
suffixStr = "(" & n & ")"

変数nをインクリメントさせて、カッコで括った文字列を変数suffixStrにぶちこむ。それだけ。

これを繰り返して、同一ファイル名が存在しなくなった時点でループから抜ける。

あとは、こうして得られたuniqueなファイルフルパスを返しておしまい。

使ってみる

ワークシートのA1セルを

f:id:akashi_keirin:20190323090417j:plain

こんなふうにして、次のコードで実験。

ちなみに、このワークシートのオブジェクト名を「MainSheet」に変更している。

スト2 標準モジュール
Public Sub test()
  MainSheet.Range("A1").Value = "ち~んw"
  Dim saveFolder As String
  saveFolder = ThisWorkbook.Path & "\★作成したPDF\"      '"
  Dim docFullName As String
  docFullName = getNameWithoutDuplication(saveFolder & "ち~んw", _
                                          "pdf")
  Call MainSheet.ExportAsFixedFormat( _
                   Type:=xlTypePDF, _
                   Filename:=docFullName)
End Sub

ご覧のとおり、ワークシートのA1セルに「ち~んw」と書き込んで、ブックのあるフォルダ内の「★作成したPDF」フォルダに「ち~んw.pdf」という名前のPDFファイルを出力する、というだけのコード。

実行結果

1回目

フォルダ内は、

f:id:akashi_keirin:20190323090424j:plain

こうなった。

2回目

フォルダ内は、

f:id:akashi_keirin:20190323090429j:plain

こうなった。意図したとおり。

3回目

フォルダ内は、

f:id:akashi_keirin:20190323090434j:plain

こうなった。やはり、意図したとおり。

おわりに

車輪の再発明だったら、教えてください。

ワークシートを任意の名前の軽量PDFにする

軽量PDFに任意のファイル名を付ける

ワークシートの軽量PDF化

ExcelのワークシートをPDF化するとき、ExportAsFixedFormatメソッドを用いると、非常に軽快に動作する反面、出来上がったPDFドキュメントのサイズが異様に大きくなってしまう。

JUST PDF等のPDF化ソフトを用いると、設定次第で極めて小さなPDFドキュメントを作成できる反面、基本的に手作業になってしまうので、数が多いと相当めんどくさい。

というわけで、

akashi-keirin.hatenablog.com

コイツを作成したのだった。

軽量PDF化ツールの弱点

しかし、そもそも上掲ツールは自動印刷のプリンタをJUST PDFに置き換えているだけなので、そもそも

任意のファイル名を指定することができない

という弱点があった。

たとえば、JUST PDF 3の場合、

f:id:akashi_keirin:20190321094647j:plain

このように、①「実行時に設定」するか、②「作成元ファイルと同じ」という設定しかない。

①の場合、任意のファイル名を指定することはできるが、保存するたびにダイアログにファイル名を入力しなければならない。目指すのが自動化である以上、この設定は論外。

②の場合、文字通り「作成元のファイル名」すなわち、「[PDF化したいExcelのブック名].pdf」という名前にしかならない。差し込み印刷のような感じで、様式にデータを挿入しつつ、一つ一つPDF化したい、というようなときに、まるで使い物にならない。

任意のファイル名を付けて軽量PDFを作成する

そこで、ちょっとやり方を考えてみた。

手順
  • 新規ブックを作成する
  • 新規ブックに必要な内容を書き込む
  • 新規ブックに任意の名前を付けて保存する
  • 新規ブックをPDFプリンタで印刷する
  • 新規ブックを閉じる
  • 新規ブックを削除する

かなり乱暴なやり方だが、このようにしてみた。

任意の名前の軽量PDFを作成するマクロ

ワークシートにテキトーに文字列を書き込んで、そのワークシートに任意の名前を付けて軽量PDF化するコードを書いてみた。

リスト1 標準モジュール
Public Sub test()
  Dim ar(1 To 10, 1 To 10) As Variant  '……(1)'
  Dim i As Long
  Dim j As Long
  For i = 1 To 10
    For j = 1 To 10
      ar(i, j) = "ち~んw"
    Next
  Next
  Dim newBook As Workbook    '……(2)'
  Set newBook = Workbooks.Add
  Dim targetFileName As String    '……(3)'
  targetFileName = ThisWorkbook.Path & "\ち~んw.xlsx"
  Call newBook.SaveAs(FileName:=targetFileName)
  Dim rng As Range    '……(4)'
  Set rng = newBook.Worksheets(1).Range("A1").Resize(10, 10)
  rng.Value = ar
  Dim originPrinter As String    '……(5)'
  originPrinter = Application.ActivePrinter
  Application.ActivePrinter = "JUST PDF 3 on Ne03:"  '……(6)'
  Call newBook.Worksheets(1).PrintOut
  Call newBook.Close(SaveChanges:=False)
  Dim fsObj As New FileSystemObject    '……(7)'
  With fsObj
    If .FileExists(targetFileName) Then _
      Call .DeleteFile(targetFileName)
  End With
  Application.ActivePrinter = originPrinter
  Set newBook = Nothing
  Set fsObj = Nothing
End Sub

内容がしょうもない割にタテ長のコードになってしまってすまない。

まずは、(1)からの8行、

Dim ar(1 To 10, 1 To 10) As Variant
Dim i As Long
Dim j As Long
For i = 1 To 10
  For j = 1 To 10
    ar(i, j) = "ち~んw"
  Next
Next

後で、新規ブックに書き込むために10×10の「ち~んw」が入った配列を準備。

(2)からの2行

Dim newBook As Workbook
Set newBook = Workbooks.Add

で、新規ブックを作成。

(3)からの3行

Dim targetFileName As String
targetFileName = ThisWorkbook.Path & "\ち~んw.xlsx"
Call newBook.SaveAs(FileName:=targetFileName)

で、(2)で作成した新規ブックに、SaveAsメソッドで「ち~んw.xlsx」というファイル名を付けて保存。

この新規ブックのフルパスは、後で使うので変数targetFileNameに入れておく。

(4)からの3行

Dim rng As Range
Set rng = newBook.Worksheets(1).Range("A1").Resize(10, 10)
rng.Value = ar

で新規ブックの一つ目のワークシートのA1セルを起点とする10×10の範囲に、(1)で作成した配列を活用して「ち~んw」を書き込む。

(5)からの2行

Dim originPrinter As String
originPrinter = Application.ActivePrinter

で、現在のActivePrinterプロパティの値を取得しておく。後で使用中のプリンタを元に戻すために用いる。

(6)からの3行

Application.ActivePrinter = "JUST PDF 3 on Ne03:"
Call newBook.Worksheets(1).PrintOut
Call newBook.Close(SaveChanges:=False)

で、一旦PDFプリンタに切り替えて印刷(すなわちPDF化)し、新規ブックを保存せずに閉じている。

JUST PDF 3 on Ne03:」の部分は、うちの環境でこうなっている、というだけなので、異なる環境のもとでは適宜改める必要がある。

これで、(JUST PDF 3使用の場合、)設定で「ファイル名」を「作成元ファイルと同じ」にしておくと、「保存先」で指定したフォルダ内に任意の名前(今回の場合だと「ち~んw.pdf」。)のPDFができる。

あとは、(7)からの5行

Dim fsObj As New FileSystemObject
With fsObj
  If .FileExists(targetFileName) Then _
    Call .DeleteFile(targetFileName)
End With

で、FileSystemObjectDeleteメソッドを用いてPDFの作成元ブック(新規ブック)を削除しておしまい。たった一つのファイルを消すためにわざわざFileSystemObjectインスタンスを作成するというこの

割鷄焉用牛刀感

たるやwww

まあ、FileSystemObjectの練習中ということで勘弁してくだされ。

実行

リスト1を実行して、PDF保存用のフォルダを覗くと……、

f:id:akashi_keirin:20190321094650j:plain

ほれ。このように「ち~んw.pdf」が燦然と輝いておる!

開いてみると、

f:id:akashi_keirin:20190321094654j:plain

バッチリ。

おわりに

かなり乱暴なやり方だという自覚はあります。