LibreOffice Calc Basic で写真一覧作成 rev.2
改訂履歴
2020年9月30日改訂 rev.2
プログラムを修正。main を実行後、セルに文字を入力しても表示されない問題がありました。
画面の更新関係で問題がありそうだったので、関連のコードを消しました。
' 画面の更新を止める(2020/09/22)
' ThisComponent.LockControllers → 削除
なお、ロック解除のつもりでロックするコードを書いていました。しかし、これをアンロックに書き換えても問題は解消しませんでした。
2020年9月22日改訂 rev.1
プログラムを修正。バグフィックスおよび機能にはあまり関係のない改良。
この記事も、それに伴って修正、さらに誤記も訂正。
プログラムの主な変更点は次のとおり
画像リスト作成（main）
シートの初期化において
・B列からF 列まで消去、消し残しは G列だけにした。
画像取り込みにおいて
・画面の更新の停止、処理中にリサイズ前の写真を表示しないようにした
・If 文で jpg ファイルだけ取り出すのではなく、Dir 関数の設定で最初から *.jpg ファイルだけを拾うように改変
・配列を使用してファイル一覧を作り、それをワークシートに転記するように改良
写真の情報処理関連
・最後の写真データおよび最後の地番データまでを処理するように修正
画像タイトル作成（MakeTitle3）
・機能変更にともない、名称を MakeTitle2 から MakeTitle3 に変更
・最初にG列を消去
・配列を使用、処理対象のデータを配列に取り込んで処理
・地番データは、あるときだけ付加
・全データをテキストファイル "Caption.txt" に書き出す。メッセージボックスには表示しない
・記事作成の利便性向上のため、画像のキャプションの間に、改行と"◇"を挟んだ形にした
概要
LibreOffice Calc Basic で写真一覧を作成することができました。
こんな感じです。
画面イメージ
説明
Sub プロシージャおよび Function 一覧
Sub Main
Sub Clear_Contents
Sub Import_Image
Sub Get_Address3
Sub Address_Code
Sub MakeTitle3
Function asin
Function min
Sub Main
次の４つを順番に実行します。
・Sub Clear_Contents
・Sub Import_Image
・Sub Get_Address2
・Sub Address_Code
Sub Clear_Contents
シートを初期化します。
１行目タイトル行を除くB列からF列のデータ、およびすべての画像を消去します。
Sub Import_Image
A列に写真をリストアップします。
B列にファイル名を書き込みます。
Sub Get_Address2
別途用意したファイルから位置情報を読み込み、写真に紐付けつつC列に書き込みます。
Sub Address_Code
Address_List というシートに記入した緯度経度の中から、最も近いものを選びます。
このブックに Address_List シートがない場合には、何もしません。
Sub MakeTitle2
キャプション用の文字列を作ります。
F列とD列から、「F列（D列）」の形の文字列を作り、G列に書きます。
最後に、すべての文字列をテキストファイル "Caption.txt" に書き出します。
Function asin
Function min
プログラムの中で、アークサイン関数および min 関数が使えなかったので、ワークシート関数を呼び出すことにしました。毎回、ワークシート関数を呼び出す手続きをとるのも面倒だと思い、Function として作りました。
データの準備
関連ファイルを同じフォルダーに置いてください。
あるフォルダー
┣ マクロファイル
┣ Picture_Address.csv
┣ jpeg ファイル１
┣ jpeg ファイル２
┣ .......
┣ .......
┣ .......
┗ jpeg ファイルX
Picture_Address.csv 写真の緯度経度情報を記録した csv ファイル
書式："jpg ファイル名","35.44157833333333, 139.29411166666665"
コンマ区切り
このファイルがない場合、写真とファイル名だけの一覧ができます。
Picture_Address.csv 作成ツール
写真に埋め込まれた位置情報を取り出すためのツールを、Python Script を用いて作りました。
このスクリプトを使えば、写真の位置情報を csv ファイルにすることができます。
マクロファイルの作成
新規スプレッドシートファイルを作成し、モジュールに上のコードを貼り付けてください。
Tools > Macros > Organize Macros > Basic
Basic Macros ダイアログで、作成したシートを選択。
Untitled 1をクリックすると、Standard とか出るので、選択。
右の New をクリック。
New Module ダイアログに、Name: Module1 と出ているので、OKをクリック。
マクロエディターの左側に、Module1 ＞ Main ができている。
全部を上書きする形で、コードを貼り付ける。
「Pictures」という名前のシートを作ってください。
Sheet1 の名称を変更するなり、新規シートを作るなりして、Pictures というシートを作ります。
A列のサイズを適当に変えます。写真は、A列のセルに収まるようにリサイズされます。
写真はリンク貼り付けです。このファイルと写真の位置関係が変わると表示されなくなります。
ちなみに、自分の場合、次の様に１行目に見出しを入れています。
A1：写真（リンク）
B1：ファイル名
C1：緯度経度
D1：地番
E1：距離
F1：タイトル
G1：キャプション
[参考]
セルの高さを一度に全部変えるときは、A列の見出し"A"をクリックしてから、1行目と2行目の境目を掴んでドラッグ。ここまで、言わなくてもいいか。
必要におうじて「Address_List」という名前のシートを用意します。
プログラム中、Address_List というシートを処理しますが、なかったらだまって無視します。
ちなみに、Address_List シートの仕様は次のとおりです。
A列：地名など。自分の場合は、地番杭に表示された記号番号です。
B列：緯度経度。（例 35.44135, 139.29426）
Address_Code という処理が、このデータの中から写真の撮影地点に最も近い地名や地番を引き出します。
マクロの実行
メニューバー > Tools > Run Macro
Macro Selector ダイアログで、このシートのModuleに含まれる、Main を選択し、Run。
「終わりました。」が表示されたら完了です。
コード
REM ***** BASIC *****
Option Explicit
REM ***********************************************************
REM シートの初期化
REM 写真取り込み
REM 位置情報紐付け
REM 番地取得
REM ***********************************************************
REM
REM 実行前に Pictures というシートを作っておく。
REM すでにある場合は、A列からG列までのコンテンツ
REM およびすべての画像を消去した上で、作り直す。
Sub Main
Call Clear_Contents
Call Import_Image
Call Get_Address2
Call Address_Code
MsgBox "終わりました。"
End Sub
REM ***********************************************************
REM シートの初期化
REM ***********************************************************
Sub Clear_Contents
Dim MySheet As Object
Dim MyCursor As Object
Dim MyRange As Object
Dim LastRow As Long
Dim drawpage As Object
Dim shape As Object
Dim i As Long
REM 事前に Pictures というシートを作ること
REM Pictures というシートがなかったら、終了。
If ThisComponent.Sheets.hasByName("Pictures") = False Then
MsgBox "このプログラムは、Pictures という名称のシートを処理します。"
End
End If
MySheet = ThisComponent.Sheets.getByName("Pictures")
'データの最終行を調べる（B列はファイル名）
MyRange = MySheet.getCellRangeByName("B1")
MyCursor = MySheet.createCursorByRange(MyRange)
MyCursor.gotoEndOfUsedArea(True)
LastRow = MyCursor.Rows.Count
' セル B2 以下にデータが存在する場合は、コンテンツを消去（B列からF列まで）
' G列は残す
If LastRow > 1 Then
MyRange = MySheet.getCellRangeByName("B2:F" & LastRow)
MyRange.ClearContents(1+2+4+8+16)
End If
'画像（shape）の消去
drawpage = MySheet.getDrawPage()
'番号の大きい方から削除, i はインデックス番号
For i = drawpage.getcount-1 To 0 Step -1
shape = drawpage.getByIndex(i)
drawpage.remove(shape)
Next i
End Sub
REM ***********************************************************
REM 写真のリストアップ
REM ***********************************************************
Sub Import_Image
REM *.jpg ファイルのリストアップ
' 縦横比固定で、セルに収める。
Dim MyUrl As String
Dim PictPath As String
Dim MyFile As String
Dim MyFolder As String
Dim MyFileCollection As Variant
Dim FileCount As Long
Dim MySheet As Object
Dim MyRow As Long
Dim LastRow As Long
Dim MyRange As Object
Dim MyRange_A As Object
Dim MyRange_B As Object
Dim MyCursor As Object
Dim MyPath As String
Dim PictName As String
Dim drawpage As Object
Dim shape As Object
Dim i As Long
Dim aSize as new com.sun.star.awt.Size
Dim aPos as new com.sun.star.awt.Point
Dim sH As Long
Dim sW As Long
Dim pX As Long
Dim pY As Long
Dim Margin_for_Image As Double
Dim Ratio_H As Double
Dim Ratio_W As Double
Dim Ratio As Double
Dim frame as Object
Dim args(1) as new com.sun.star.beans.PropertyValue
Dim args1() As new com.sun.star.beans.PropertyValue
Dim pictUrl As String
Dim args2(1) As Variant
Dim controller AS Object
Dim dispatcher As Object
' セルに対して 2.5% ずつ余白を作って画像を貼り付ける
Margin_for_Image = 0.025
REM Pictures というシートがなかったら、終了。
If ThisComponent.Sheets.hasByName("Pictures") = False Then
MsgBox "このプログラムは、Pictures という名称のシートを処理します。"
End
End If
MySheet = ThisComponent.Sheets.getByName("Pictures")
MyRow = 2
'---- ファイルを検索 -----
'このファイルのURL
MyUrl = ThisComponent.getUrl
' URL表現から普通のファイルパスに変換
MyPath = ConvertFromURL(MyUrl)
'このファイルのファイル名
MyFile = Dir(MyUrl, 16)
'このファイルが所属するフォルダー
'ファイルのフルパスの左何文字かを取り出す。
'文字数は、フルパスの文字数からファイル名の文字数を引いたもの
'結果、"/"まで含む。
MyFolder = Left(MyPath, Len(MyPath) - Len(MyFile))
' ーーーーーーーー 差し替え（2020/09/22） ーーーーーーーー
' 配列を使ってファイルリストを作る
FileCount = 0
'このシートと同じフォルダーにあるファイルを調べ、jpg だったらシートに記入する。
'Dir 関数を使って最初のファイルをゲット
MyFile = Dir(MyFolder + "*.jpg")
' <> "._" という条件は、NAS の隠しファイルまで読み込むのを阻止するため
Do While MyFile <> ""
If Left(MyFile, 2) <> "._" then
Redim Preserve MyFileCollection(FileCount)
MyFileCollection(Ubound(MyFileCollection)) = Array(MyFile)
FileCount = FileCount + 1
End If
MyFile = Dir()
Loop
'B2 から貼り付け
'最後の行を計算
LastRow = 2 + Ubound(MyFileCollection)
'貼り付け先の範囲
MyRange = MySheet.getCellRangeByName("B2:B" & LastRow)
'配列をシートにコピー
MyRange.setDataArray(MyFileCollection)
' ーーーーーーーー 差し替えここまで ーーーーーーーー
' ---- 画像貼り付け ----
'
' http://hermione.s41.xrea.com/pukiwiki/index.php?OOoBasic%2FCalc%2Fimage
'
drawpage = MySheet.getDrawPage()
' B列のファイル名から画像を読み込んで、セルに貼り付ける。
controller = ThisComponent.getCurrentController()
frame = controller.getFrame()
dispatcher = CreateUnoService("com.sun.star.frame.DispatchHelper")
For MyRow = 2 To LastRow
REM 列Aのセルの大きさを調べる
MyRange_A = MySheet.getCellRangeByName("A" & MyRow)
'小数点以下、四捨五入
With MyRange_A
sW = CLng(.Size.Width * (1 - Margin_for_Image * 2))
sH = CLng(.Size.Height * (1 - Margin_for_Image * 2))
pX = CLng(.Position.X + sW * Margin_for_Image)
pY = CLng(.Position.Y + sH * Margin_for_Image)
End With
REM B列からファイル名をゲット
MyRange_B = MySheet.getCellRangeByName("B" & MyRow)
PictName = MyRange_B.String
PictPath = MyFolder + PictName
' システムファイル名をファイルURLへ変換
pictUrl = ConvertToURL(PictPath)
' プロパティーの設定
' 画像のファイル名およびリンク貼り付け
args(0).Name = "FileName"
args(0).Value = pictUrl
args(1).Name = "AsLink"
args(1).Value = True
' 画像の挿入
REM セルを選択し、フレームとして設定
Controller.Select(MyRange_A)
frame = Controller.getFrame()
REM 画像の挿入
dispatcher.executeDispatch(frame, ".uno:InsertGraphic", "", 0, args)
' 最後に貼り付けた画像（と思われるもの）を、shape に設定、選択したのちフレームとして設定
shape = drawpage.getByIndex(drawpage.getcount-1)
controller.Select(shape)
frame = controller.getFrame()
REM ----------------------------------------------------------------------
REM マクロ自動記録から、Document となっていたところを、frame に変更。
REM 画像のアンカーを設定する。
REM args1() は、空の配列。
dispatcher.executeDispatch(frame, ".uno:SetAnchorToCell", "", 0, args1())
' 画像のサイズを設定
' 幅に合わせたときと高さに合わせたときの縮尺を計算する。
Ratio_W = sW / shape.Graphic.SizePixel.Width
Ratio_H = sH / shape.Graphic.SizePixel.Height
' 関数 min に渡す引数を用意する
Args2(0) = Ratio_W
Args2(1) = Ratio_H
' 小さい方を求めるために、Function min を作った。
' とはいえワークシート関数を使うだけのルーチンだ。
Ratio = min(args2())
' 幅と高さを決定
aSize.Width = shape.Graphic.SizePixel.Width * Ratio
aSize.Height = shape.Graphic.SizePixel.Height * Ratio
' 貼り付けた画像に適用
shape.Size = aSize
' 画像の位置を設定
aPos.X = pX
aPos.Y = pY
shape.Position = aPos
REM 画像の Description > Title: にファイル名を書き込む。
shape.title = PictName
Next MyRow
End sub
REM ***********************************************************
REM csv ファイルから写真の位置情報を取り込む
REM ***********************************************************
Sub Get_Address2
' 写真リストと csvファイルのデータを結びつける。
' ファイル名：Picture_Address.csv
' 文字コード：utf-8
' データ形式："写真のファイル名","緯度経度"
Dim MyController As Object
Dim MyCursor As Object
Dim MyFolder As String
' マクロシート関連
Dim MyURL As String
Dim MyPath As String
Dim MyFile As String
Dim MySheets As Object
Dim MySheet As Object
Dim MyRange AS Object
Dim MyRow As Long
Dim MyLastRow As Long
' csvファイル関連
Dim CSVPath As String
Dim CSVUrl As String
Dim CSVBook As Object
Dim CSVSheets As Object
Dim CSVSheet As Object
Dim CSVRange As Object
Dim CSVRow As Long
Dim CSVLastRow As Long
Dim CSVData As Object
Dim FileProperties(1) As New com.sun.star.beans.PropertyValue
REM Pictures というシートがなかったら、終了。
If ThisComponent.Sheets.hasByName("Pictures") = False Then
MsgBox "このプログラムは、Pictures という名称のシートを処理します。"
End
End If
' csv ファイル読み込み用プロパティー設定
FileProperties(0).Name = "FilterName"
FileProperties(0).Value = "Text - txt - csv (StarCalc)"
FileProperties(1).Name = "FilterOptions"
FileProperties(1).Value = "44,34,76,1,2/1/1/1/1"
'
'FilterOptions プロパティについて
'
'セルの区切り文字を ASCII コードで指定。コンマ: 44
'テキストを囲む文字を ASCII コードで指定。ダブルクォート: 34
'テキストの文字コード Unicode: 65535, UTF-8: 76, UTF-7: 75, EUC-JP: 69, Shift_JIS: 64, ISO-2022-JP: 72
'エクスポートし始める行
'セルのタイプ指定 1: 数値, 2: テキスト, 3: MM/DD/YY, 4: DD/MM/YY, 5: YY/MM/DD, 6, 7, 8: テキスト, 9: セルを無視, 10: US タイプの数値フォーマット です。各フィールドに複数の値を指定する際には，数値を "/" で区切ります。
'利用可能な文字コード数値はソースコードの textenc.h で確認できます。とのこと。
' ---- このフォルダー -----
'このファイルのURL
MyUrl = ThisComponent.getUrl
' URL表現から普通のファイルパスに変換
MyPath = ConvertFromURL(MyUrl)
'このファイルのファイル名
MyFile = Dir(MyUrl, 16)
'このファイルが所属するフォルダー
'ファイルのフルパスの左何文字かを取り出す。
'文字数は、フルパスの文字数からファイル名の文字数を引いたもの
'結果、"/"まで含む。
MyFolder = Left(MyPath, Len(MyPath) - Len(MyFile))
' ---- csv ファイルがあるかを調べる ----
CSVPath = MyFolder + "Picture_Address.csv"
If Dir(CSVPath) = "" Then
Print "GPS データ（Picture_Address.csv）がありません。"
Exit Sub
End If
' ---- csv ファイルを開く ----
CSVURL = ConvertToURL(CSVPath)
CSVBook = StarDesktop.loadComponentFromURL(CSVURL, "_default", 0, FileProperties)
MyController = CSVBook.getCurrentController()
CSVSheets = CSVBook.getSheets()
CSVSheet = CSVSheets.getByName("Picture_Address")
' ---- csvファイルの最終行 ----
CSVRange = CSVSheet.getCellRangeByName("A1")
MyCursor = CSVSheet.createCursorByRange(CSVRange)
MyCursor.gotoEndOfUsedArea(True)
CSVLastRow = MyCursor.Rows.Count
' ---- このシートの最終行 -----
' MySheet = ThisComponent.CurrentController.Activesheet
MySheet = ThisComponent.Sheets.getByName("Pictures")
MyRange = MySheet.getCellRangeByName("B1")
MyCursor = MySheet.createCursorByRange(MyRange)
MyCursor.gotoEndOfUsedArea(True)
MyLastRow = MyCursor.Rows.Count
' 写真一覧ファイルの２行目から最後の行まで処理する
For MyRow = 2 To MyLastRow
' B列のデータ＝ファイル名
MyRange = MySheet.getCellRangeByName("B" & MyRow)
' GPS データファイルの１行目から最後の行まで処理する
For CSVRow = 1 To CSVLastRow
'A列のデータ＝ファイル名
CSVRange = CSVSheet.getCellRangeByName("A" & CSVRow)
' ファイル名の一致を確認して、位置情報取り込み
If CSVRange.String = MyRange.String Then
' このシートに、GPS ファイルから次のデータを書き込む
' C列に B列のデータ（緯度,経度）
CSVRange = CSVSheet.getCellRangeByName("B" & CSVRow)
MyRange = MySheet.getCellRangeByName("C" & MyRow)
MyRange.String = CSVRange.String
Exit For
End If
Next CSVRow
Next MyRow
CSVBook.close(True)
End Sub
REM ***********************************************************
REM Address_List シートから、もっとも近い Location Name をみつける
REM ***********************************************************
REM Address_List シートがない場合には、だまって無視。
REM 結果、簡単な写真リストが出来上がる。
REM Address_List シートの仕様
' A列：場所、自分の場合は、地番杭に表示された記号番号
' B列：緯度経度（例 35.44135, 139.29426）
Sub Address_Code
' Address_List シート
' A列 地名などの名称
' B列 緯度経度 書式の例 35.44135, 139.29426
Dim MySheet As Object
Dim MyRow As Long
Dim MyCursor As Object
Dim LastRow As Long
Dim MyRange As Object
Dim MyData As Variant
Dim AddressSheet As Object
Dim MyRange_A As Object
Dim AddressList As Variant
Dim i As Long
Dim j As Long
Dim MyString As String
Dim Distance As Double
Dim lat0 As Double
Dim lat1 As Double
Dim lon0 As Double
Dim lon1 As Double
Dim Phi0 As Double
Dim Phi1 As Double
Dim Lambda0 As Double
Dim Lambda1 As Double
Dim radius As Long
Dim term1 As Double
Dim term2 As Double
REM Pi = 3.1415926 は事前定義されている定数で、円周率の近似値
radius = 6378137 '地球の Radius 単位は、メートル
REM Pictures というシートがなかったら、終了。
If ThisComponent.Sheets.hasByName("Pictures") = False Then
MsgBox "このプログラムは、Pictures という名称のシートを処理します。"
Exit Sub
End If
MySheet = ThisComponent.Sheets.getByName("Pictures")
'データの最終行を調べる
MyRange = MySheet.getCellRangeByName("B1")
MyCursor = MySheet.createCursorByRange(MyRange)
MyCursor.gotoEndOfUsedArea(True)
LastRow = MyCursor.Rows.Count
MyRange = MySheet.getCellRangeByName("C2:E" & LastRow)
MyData = MyRange.getDataArray
' Address_List シートの A列と B列を配列に格納する。
If ThisComponent.Sheets.hasByName("Address_List") = False Then
REM Address_List というシートがなかったら、処理を終了。
Exit Sub
End If
AddressSheet = ThisComponent.Sheets.getByName("Address_List")
MyRange_A = AddressSheet.getCellRangeByName("A2:B132")
AddressList = MyRange_A.getDataArray
' Ubound(MyData) - 1 としていたために最後のデータを処理していなかった。
' 1 を引くのをやめる。2020/09/22
For i = 0 To UBound(MyData)
'緯度経度 MyData(i)(0)
'地番 Mydata(i)(1)
'距離 MyData(i)(2)
Mydata(i)(1) = ""
'未処理であることを示すために、距離に -1 を入れておく。
Mydata(i)(2) = -1
If Instr(MyData(i)(0), ",") > 0 Then
'緯度経度のデータはコンマで区切られているので、split で分割する。
lat0 = Split(MyData(i)(0), ",")(0)
lon0 = Split(MyData(i)(0), ",")(1)
'ラジアンに変換
Phi0 = lat0 * Pi/180
Lambda0 = lon0 * Pi/180
' Ubound(AddressList) - 1 としていたため、最後の地番を無視していた。
' 1 を引くのをやめる。2020/09/22
For j = 0 To Ubound(AddressList)
'地番 AddressList(j)(0)
'緯度経度 AddressList(j)(1)
'距離を計算する
If Instr(AddressList(j)(1), ",") > 0 Then
'緯度経度のデータはコンマで区切られているので、split で分割する。
lat1 = Split(AddressList(j)(1), ",")(0)
lon1 = Split(AddressList(j)(1), ",")(1)
'ラジアンに変換
Phi1 = lat1 * Pi/180
Lambda1 = lon1 * Pi/180
'一気に公式を書かずに、項ごとに計算する。
term1 = sin((phi1 - Phi0) / 2.0) ^ 2
term2 = sin((Lambda1 - Lambda0) / 2.0) ^ 2
term2 = cos(Phi0) * cos(Phi1) * term2
Distance = 2.0 * radius * asin(sqr(term1 + term2))
'asin は アークサイン、実行時関数として存在しないのか。
'Function として作った。
If Mydata(i)(2) = -1 Then
'最初の距離データを格納
Mydata(i)(2) = Distance
MyData(i)(1) = AddressList(j)(0)
Else
'距離の数値が小さい方を残す
If Mydata(i)(2) > Distance Then
Mydata(i)(2) = Distance
MyData(i)(1) = AddressList(j)(0)
End If
End If
End If
Next j
End If
Next i
'地番と距離を書き込んだ配列を、元のレンジに書き戻す。
MyRange.setDataArray(MyData)
End Sub
REM ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
REM ２．手入力したタイトルと地番から、画像のキャプションを生成する
REM ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub MakeTitle3
' F列 + ( + D列 + ) を G列に書く
' 全データをテキストファイル "Caption.txt" に書き出す。(2020/09/22)
Dim MySheet As Object
Dim MyRow As Long
Dim MyRange As Object
Dim MyCursor As Object
Dim LastRow As Long
Dim I As Long
Dim MyUrl As String
Dim MyPath As String
Dim MyFile As String
Dim MyFolder As String
Dim TextFilePath As String
Dim FileNumber As Long
Dim Data_D As Variant
Dim Data_F As Variant
Dim Data_G As Variant
Dim MyData As String
Dim MyString As String
REM Pictures というシートがなかったら、終了。
If ThisComponent.Sheets.hasByName("Pictures") = False Then
MsgBox "このプログラムは、Pictures という名称のシートを処理します。"
End
End If
MySheet = ThisComponent.Sheets.getByName("Pictures")
' G列の最終行を調べる
MyRange = MySheet.getCellRangeByName("G1")
MyCursor = MySheet.createCursorByRange(MyRange)
MyCursor.gotoEndOfUsedArea(True)
LastRow = MyCursor.Rows.Count
' セル G2 以下にデータが存在する場合は、コンテンツを消去（G列だけ）
If LastRow > 1 Then
MyRange = MySheet.getCellRangeByName("G2:G" & LastRow)
MyRange.ClearContents(1+2+4+8+16)
End If
' B列の最終行を調べる
MyRange = MySheet.getCellRangeByName("B1")
MyCursor = MySheet.createCursorByRange(MyRange)
MyCursor.gotoEndOfUsedArea(True)
LastRow = MyCursor.Rows.Count
' １個ずつセルを読み書きするのはやめて、配列を使って処理する (2020/09/22)
' D列：地番のデータを配列に取り込む
MyRange = MySheet.getCellRangeByName("D2:D" & LastRow)
Data_D = MyRange.getDataArray
' F列：タイトルを配列に取り込む
MyRange = MySheet.getCellRangeByName("F2:F" & LastRow)
Data_F = MyRange.getDataArray
' G列のデータを入れる配列を用意する
' 最大インデックスは、最終行から最初の行を引いた数
ReDim Data_G(LastRow - 2)
' 地番データがあるときだけ、括弧付きで地番データを追加
For I = 0 To Ubound(Data_G)
If Data_D(I)(0) <> "" Then
Data_G(I) = Array(Data_F(I)(0) & "（" & Data_D(I)(0) & "）")
Else
Data_G(I) = Array(Data_F(I)(0))
End If
MyString = MyString & Chr(13) & Data_G(I)(0) & Chr(13) & "◇"
Next I
' ワークシートに書き出す
MyRange = MySheet.getCellRangeByName("G2:G" & LastRow)
MyRange.setDataArray(Data_G)
' G列のデータ用の配列の要素をすべて結合する。
' 間に、改行と◇を挟む
MyString = Join(Data_G, Chr(13) & Chr(10) & "◇" & Chr(13) & Chr(10))
' 結果は、メッセージボックスに表示しない。
' テキストファイル "Caption.txt" に書き出す。2020/09/22
'このファイルのURL
MyUrl = ThisComponent.getUrl
' URL表現から普通のファイルパスに変換
MyPath = ConvertFromURL(MyUrl)
'このファイルのファイル名
MyFile = Dir(MyUrl, 16)
'このファイルが所属するフォルダー
'ファイルのフルパスの左何文字かを取り出す。
'文字数は、フルパスの文字数からファイル名の文字数を引いたもの
'結果、"/" まで含む。
MyFolder = Left(MyPath, Len(MyPath) - Len(MyFile))
TextFilePath = MyFolder & "Caption.txt"
' ファイルのオープン
FileNumber = FreeFile()
Open TextFilePath For Output As #FileNumber
' 出力
Print #FileNumber , MyString
' ファイルのクローズ
Close #FileNumber
MsgBox "終わりました。"
End Sub
REM ***********************************************************
REM アークサイン関数
REM ***********************************************************
REM 引数は、一つの数値
Function asin(Number As Double)
Dim ShtFunc As Object
Dim Args(0) As Variant
ShtFunc = CreateUnoService( "com.sun.star.sheet.FunctionAccess" )
Args(0) = Number
asin = ShtFunc.callFunction("ASIN", Args())
End Function
REM ***********************************************************
REM 最小値を求める関数
REM ***********************************************************
REM 引数は配列で渡す
Function min(Args As Variant)
Dim ShtFunc As Object
ShtFunc = CreateUnoService( "com.sun.star.sheet.FunctionAccess" )
min = ShtFunc.callFunction("MIN", Args())
End FunctionCaption.txt のサンプル
キイトトンボ（E30）
◇
キイトトンボ（E30）
◇
オオシオカラトンボ（K16）
◇
クロイトトンボ（K16）
◇
キイトトンボ（K16）
◇
コゲラ
◇
写真につけるキャプションを生成する場合は、F列に文字を記入した後で、MakeTitle3 を実行します。
参考にしたサイト
主に次のサイトを参考にしました。
画像の貼り付け
指定したシートがあるかどうか
データが入力されている最終行・最終列を求める
セルの内容をクリアする
画像の消去
CSV ファイルの取り扱い
Haversine formula を使って２点間の距離を求める
ワークシート関数を LO Basic で使う方法
余談
これを使ったワークフロー的な話は、また別の機会にしたいと思います。
Python でやれば楽なのに、あえて LO Calc に取り込んだ話
緯度経度から距離を求めるときに Haversine formula という公式があると知りました。 最初、流れで Python のモジュールを使ったら楽にできるとか考えましたので、距離の計算も Python スクリプトでやっていました。しかし、基準となる番地と緯度経度は、元は LO Calc で作りますし、モジュールを使わず式で計算するようになって、LO Basic でやったら良いだろうとなりました。
しかし、LO Basic のネックは、Python ほど楽に計算できないところでしょうか。Python の場合、配列を一気に処理するみたいなことが簡単にできてしまいます。LO Basic の場合は、地味に処理していかなければならないことが多い気がします。
ま、しかしやればなんとかなると、緯度経度を取り出すところだけ Python に任せることにして、距離の計算を LO Basic に移植しました。あと、あれこれ改善してやっと完成しました。
LO Calc のマクロ取り込みが使えない話
マクロを記録しても、完全な形で記録されない場合がありますね。本当に困ります。そんなときは諦めた方が良いのでしょうね。
もっとも、そのような場合、マクロやプログラムでどうしようもないことだったりするようです。すくなくとも、自分の知識や情報収集能力ではどうにもならないことがよくあります。
今回、貼り付けた写真を圧縮したいと思っていろいろ試行錯誤しました。が、結局、圧縮するのはあきらめて、リンク貼り付けという代替手段で落ち着きました。リンクなら取り込んだものを圧縮する以上にファイルサイズを節約できますので、これでよかったかなと思います。
アプリケーション上は、画像を右クリックして、Compress... から圧縮できます。
その操作をマクロを記録すると、↓こうです。
sub compress
rem ----------------------------------------------------------------------
rem define variables
dim document as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
rem ----------------------------------------------------------------------
rem dispatcher.executeDispatch(document, ".uno:CompressGraphic", "", 0, Array())
end sub肝心なところが rem として書かれています。これを実行しても何も起きません。パラメーターを設定すれば動作するのではないかと思ったのですが、そんな簡単な話ではないみたいで、いくら調べても解決策が見つかりませんでした。
しかし、なんでこんな制約があるのか理解できません。できるようにしてくれたらいいじゃないかと思います。
しかし、自分の理解が足りないのかもしれません。DispatchHelper を理解すればできるようになるかと思って、勉強しました。
理解できませんでした。使える情報がほしいです。
executeDispatch()
any executeDispatch ( [in] XDispatchProvider DispatchProvider,
[in] string URL,
[in] string TargetFrameName,
[in] long SearchFlags,
[in] sequence< com::sun::star::beans::PropertyValue > Arguments
)
Parameters
DispatchProvider points to the provider, which should be asked for valid dispatch objects
URL describes the feature which should be supported by internally used dispatch object
TargetFrameName specifies the frame which should be the target for this request
SearchFlags optional search parameter for finding the frame if no special TargetFrameName was used
Arguments optional arguments for this request They depend on the real implementation of the dispatch object.
結局、".uno:CompressGraphic" は、有効なパラメーターを持っていないのでしょうか。
これの Arguments が、公式ドキュメントに明示されていたら楽だと思うのですが、無理なことなのでしょうか。
t.koba
この記事が気に入ったらサポートをしてみませんか？