【画像内の寸法を測定する】【エクセル2013,VBA】
画像に写し込んだ物差し（大きさがわかっていれば何でも良い）のサイズをもとに画像内の物体の寸法を測定するコード。
最初に
・専用ソフトや携帯アプリでこと足りるならそちらをお勧めします。エクセルでやりたいひと向けです。
・画像の大きさ次第のところもありますが、精度がそこまでよくありません。画像が小さく、表示の拡大を行うと微妙にずれます。
・測定途中でやめると、カーソルが矢印に固定されてしまうので注意してください。
クリック動作の検出
始点と終点をクリックしてその2点の距離を測定したいのだが、クリック動作の検出が必須となる。そのためには主に以下の4つがあるそうです。
1. GetAsyncKeyState API
2. GetMessage API
3. サブクラス化
4. マウスの低レベルフック(グローバルフック)
シート上でマウスイベントを検出する方法 | ヴィーバ VeaBa! Excel VBA Tips
1と2がお手軽だがループ処理が必要なため負荷がかかり、カーソルが青丸（処理中）になってしまったのでボツに（ピンポイントで指定できない）。3,4は難しそうなので回避（4はしっかり理解していないと危険とのコメントも）。
つぎにワークシートファンクションでできないかとも考えたが、画像上だとクリック動作の検出ができなかったのでボツ。
そこで、小手先な感じもするがカーソル位置を返すコードを作成し、画像にいわゆるマクロの登録をすることで、クリック動作の検出と画像上のカーソル位置取得を行うことにした。
以下コードの概要
1.ダイアログボックスから画像ファイルを選択する。
2.画像がシートに読み込まれる。画像にカーソルの位置を返すマクロが登録される。
3.画像上のどこかをクリックすると、カーソルが指の形から矢印に変わる。
4.始点をクリック。
5.終点をクリック。始点から終点まで線が引かれ、線の長さがカラムB、Cに出力されていく(Bはピクセル、Cは物差しの長さをもとに計算された値）。線の左上には通し番号を表示。
以下3〜6を繰り返すと複数回、寸法測定が可能。1回目は基準となる物差しの始点と終点を選択し、物差しのサイズを入力すると以降は物差しのサイズをもとに長さが出力される。
例：将棋盤の枡目を物差しとして駒の寸法を測定
0と1は枡目=3cm
=======================================================
以下コード
Dim state As Long, PosiPix(1 To 2, 1 To 2) As Long
Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
CPosix As Long
Cposiy As Long
End Type
'メインコード
Sub 寸法測定開始()
ActiveSheet.Pictures.Insert(File選択("画像を選択してください。")).Select
'画像の位置指定
Selection.ShapeRange.Left = 200
Selection.ShapeRange.Top = 10
'画像にマクロの登録を行う（＝クリックされると寸法測定が動作する）
Selection.OnAction = "寸法測定"
Application.Cursor = xlDefault
state = 1
End Sub
'寸法を測定するコード
Sub 寸法測定()
'1回目のクリック→カーソルを指から矢印に変える
'2回目のクリック→開始点を記録
'3回目のクリック→開始点と終了点に破線をひき距離を書き出す
Dim i As Long
Select Case state 'stateにより何回目のクリックか判別
Case 2 '2回目のクリックなら
'開始点の座標を記憶
PosiPix(1, 1) = GCPPixX
PosiPix(1, 2) = GCPPixY
state = 3
Case 3 '3回目のクリックなら
'終了点の座標を記憶
PosiPix(2, 1) = GCPPixX
PosiPix(2, 2) = GCPPixY
'開始点と終了点に破線をひく
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, PosiPix(1, 1), PosiPix(1, 2), PosiPix(2, 1), PosiPix(2, 2)). _
Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.DashStyle = msoLineSysDot
.Weight = 0.5
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
'結果の書き込み位置の確認。3行目以降の空欄に書き込む。
For i = 3 To 102
If Cells(i, 1) = "" Then
Exit For
End If
Next
'上記破線の左上に通し番号のラベルをつける
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, PosiPix(1, 1) - 5, PosiPix(1, 2), 25, 20).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = i - 3
Selection.ShapeRange.IncrementTop -10
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 6
'通し番号
Cells(i, 1) = i - 3
'一回目の場合のみ、画像内のものさしを設定（定規、10円玉、たばこetc,なんでもいい）
If i = 3 Then
'ものさしの幅を入力（単位はない）
Cells(3, 3) = InputBox("Sizeを入力", "入力", "1")
End If
'ピクセル単位での2点間の距離をB列に記入
Cells(i, 2) = Sqr*1 ^ 2 + (PosiPix(1, 2) - PosiPix(2, 2)) ^ 2)
'ものさしの長さをもとに計算した2点間の距離をＣ列に記入
Cells(i, 3) = Cells(i, 2) / Cells(3, 2) * Cells(3, 3)
'初期状態にもどす。
Application.Cursor = xlDefault
state = 1
Case Else '1回目のクリック
state = 2
Application.Cursor = xlNorthwestArrow 'カーソルを指から矢印に変え
End Select
End Sub
Function GCPPixX() As Single
'カーソルのエクセル内でのX座標(Pixel)を返すファンクション。
Dim Pos As POINTAPI
GetCursorPos Pos
GCPPixX = (Pos.CPosix - ActiveWindow.PointsToScreenPixelsX(0)) / ActiveWindow.Zoom * 100 / 96 * 72
End Function
Function GCPPixY() As Single
'カーソルのエクセル内でのY座標(Pixel)を返すファンクション。
Dim Pos As POINTAPI
GetCursorPos Pos
GCPPixY = (Pos.Cposiy - ActiveWindow.PointsToScreenPixelsY(0)) / ActiveWindow.Zoom * 100 / 96 * 72
End Function
Function File選択(titlestr As String) As String
'ダイアログでファイルを選択し、選択されたファイルのパスを返すファンクション。
If titlestr = "" Then
titlestr = "ファイル選択"
End If
With Application.FileDialog(msoFileDialogFilePicker)
.Title = titlestr
If .Show = -1 Then 'アクションボタンがクリックされた
File選択 = .SelectedItems(1)
Else 'キャンセルボタンがクリックされた
File選択 = "CANCEL"
End If
End With
End Function
*1:PosiPix(1, 1) - PosiPix(2, 1
【シート上の画像をファイルとして保存する】【エクセル2013,VBA】
VBAを使わないでシート上の画像をファイルとして保存する方法
Excel シートに貼り付けた画像をファイルとして保存するには
VBAを使ってシート上の画像をファイルとして保存する方法
下に記したやり方だと画質が落ちる気がするので、上記の方法を使えるなら上記の方法がよい気がする。
画像をいきなりファイルとして保存することはできない様子。だがグラフであればエクスポートにより画像として保存するメソッドがあるのでこれを利用する。つまりは空のグラフをつくり、その中に画像を表示しエクスポートすることでシート上の画像をファイルとして保存できる。
Excel/VBAクリニック，今月の診断 - 第37回 グラフを画像ファイルに保存する：ITpro
以下シート上の全画像をファイルとして保存するコード。ファイルはデスクトップにオブジェクト名で保存される。
============================================================
Sub 保存()
'ワークシートの全オブジェクトをループ
For Each tobj In ActiveSheet.Shapes
If tobj.Type = 13 Then'オブジェクトが画像ならType=13となる。
tobj.CopyPicture
Fname = tobj.Name'オブジェクトの名前を取得
ACWidth = tobj.Width'オブジェクトのサイズを取得（高さ）
ACHeight = tobj.Height'オブジェクトのサイズを取得（高さ）
'オブジェクトとほぼ同サイズの空のグラフを一時的に作る
Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart
TCht.Paste’グラフに画像をペーストする。
’エクスポート先はデスクトップ。ファイル名はオブジェクト名。タイプはJPG（書き換えればpng等でもいける。）
TCht.Export Filename:=myDeskTopPath & Fname & ".jpg", filtername:="JPG"
TCht.Parent.Delete’グラフを削除する。
End If
Next
End Sub
Function myDeskTopPath()
' デスクトップパスの取得
Dim MyWSH As Object
Set MyWSH = CreateObject("WScript.Shell")
myDeskTopPath = MyWSH.SpecialFolders("Desktop")
Set MyWSH = Nothing
End Function
【アドインを自動化する】【エクセル2013,VBA】
「これ昔似たようなコード書いたことがあるけど、どのブックに書いたっけ？探すの面倒だからまた新しく書いちゃえ。」みたいなことになったりしないでしょうか？そうなると使い方が微妙に違う亜種がいくつも発生したり、探すのが余計に面倒になったりします。コードは部品化して再利用すると、効率よく新しい機能を作れ、保守（不具合の修正など）も楽になるのですが、亜種の存在は効率性と保守性に問題を生じさせます。
また多くの第三者にいくつもの機能を使用してもらう際には、「1.配布、2.機能の追加・修正、3.利用」に問題が生じます。
1.配布
利用者はエクセルに詳しくない人が多いです。機能を利用するための設定が面倒な場合は、設定に手間取るか放棄する（あなたへの助力を求めることを含む）かのどちらかです。
2.機能の追加・修正
機能の追加や修正は必ずあるものです。追加や修正が面倒な場合は、配布時と同様の問題が生じます。また利用者は配布済みのファイルを自分が使いやすいようにアレンジしたりしている（例えば名前欄やメールアドレス欄に自分の情報を入力してる）ことが多いので、旧バージョンでも本人にとって問題なければ場合、簡単には手放してくれませんし、そのファイルが流通し続けることがあります。
3.利用
作成者以外にとって、機能が多い場合、どのような機能があるか、どうすれば利用できるかを把握することは容易ではありません。詳細な説明書を作成する気にもなれないでしょう。
エクセルアドインの利用と自動化のメリット
エクセルアドインはリボンにあるコピーやペースト同様の操作で自分が作った機能を選択することを可能にします。機能の把握と利用がとても容易になります。ただしアドインの設定は知らない人にとって、面倒です。
アドインに存在する機能はすべてのエクセルファイルから呼び出せるのでアドインにコードがあれば各ファイルごとにコードを記述する必要はありません。コードの多重化が少なくなります。書類の雛形シートなどもアドインファイルの中に保存しておいて、必要なシートのみコピーして使うようにすればいろいろ便利です。
アドインの自動化コードがあれば利用者はワンクリックで設定や機能の追加が可能となります。
以下コードアドインの自動化コード
=============================================================
'Sub プロシージャ内に記述
Sub SaveAsAddin()
'ボタンに本コードを登録するとワンクリックでアドインが可能となる。
Dim tst As String, FN As String
On Error GoTo ELH
'アドイン形式で保存されるアドイン名。なんでもよい。
tst = "AutoAddin1"
'保存場所。
FN = "C:\Users\" & GetUserName & "\AppData\Roaming\Microsoft\AddIns\" & tst & ".xlam"
'保存したいファイルと同名のファイルがあった場合、updateとみなしアドインをアンインストールする。
If Dir(FN) <> "" Then
'アンインストール。自動的にワークブックイベントのPrivate Sub Workbook_AddinUninstallが実行されメニューバーが削除される。
AddIns(tst).Installed = False
End If
Application.DisplayAlerts = False
'アドイン形式で保存する。
ActiveWorkbook.SaveAs Filename:=FN, FileFormat:=xlOpenXMLAddIn, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
'アンインストール。自動的にワークブックイベントのPrivate Sub Workbook_AddinInstallが実行されメニューバーが追加される。
AddIns(tst).Installed = True
MsgBox "インストールが完了しました。"
Exit Sub
ELH:
MsgBox "アドインをインストールできませんでした。"
End Sub
Function GetUserName()
'ユーザーネームを取得するファンクション
Dim WshNetworkObject As Object
Set WshNetworkObject = CreateObject("WScript.Network")
With WshNetworkObject
GetUserName = .UserName
End With
Set WshNetworkObject = Nothing
End Function
Sub 機能1()
'ここに"サブサブメニューバー1"がクリックされた際の機能を記述する。
MsgBox "機能1"
End Sub
Sub 機能2()
'ここに"サブサブメニューバー1"がクリックされた際の機能を記述する。
MsgBox "機能2"
End Sub
Sub Addin手動削除()
'上記コードで登録されたAutoAddin1をアンインストールしメニューバーを削除する
Dim MBname As String
AddIns("AutoAddin1").Installed = False
'削除するメニューバーの名前
MBname = "メニューバー1"
Application.CommandBars("Worksheet Menu Bar").Controls(MBname & "(&C)").Delete
End Sub
'!!!!!ここからワークブック イベントプロシージャに記述!!!!!
Private Sub Workbook_AddinInstall()
'メニューバー追加
Dim NewM As Variant, NewC As Variant, MBname As String
'追加するメニューバー
MBname = "メニューバー1"
'新しいメニューを追加する
Set NewM = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
NewM.Caption = MBname & "(&C)"
'サブメニューを追加する
Set NewC = NewM.Controls.Add(Type:=msoControlPopup)
With NewC
.Caption = "サブメニューバー1"
.BeginGroup = True
With NewC.Controls.Add()
.Caption = "サブサブメニューバー1"
.OnAction = "機能1" 'サブサブメニューバー1が選択されたときに実行されるSubプロシージャ名
End With
With NewC.Controls.Add()
.Caption = "サブサブメニューバー2"
.OnAction = "機能2" 'サブサブメニューバー2が選択されたときに実行されるSubプロシージャ名
End With
End With
End Sub
Private Sub Workbook_AddinUninstall()
On Error Resume Next
Dim MBname As String
'削除するメニューバーの名前
MBname = "メニューバー1"
Application.CommandBars("Worksheet Menu Bar").Controls(MBname & "(&C)").Delete
End Sub
===============================================================
補足
アドイン設定基本
http://booyan.lopan.jp/excel_addin/
コード説明
Sub SaveAsAddin （メイン）
コードが書かれているエクセルファイルをアドイン形式で保存後、インストールする。
内容
1.保存先を設定するためにユーザー名を取得する(*1)。ちなみに多くのユーザーに配布する場合、エクセルファイルのシートの一枚に各種情報の記載された名簿を用意し、ユーザー名をもとに各種情報（メールアドレスや部署など）を取得するコードを組み込むことでユーザーに応じた初期設定まで自動化まで可能です。
2.保存したいファイルと同名のファイルが存在するか確認する。存在した場合は、修正とみなし以前のアドインをアンインストールする。アンインストールされた場合、ワークブックイベントから自動的にメニューバーの削除が実行される(*2)。
3.アドイン形式で保存後、アドインをインストールする。インストールされた場合、ワークブックイベントから自動的にメニューバーの追加が実行される(*3)。
ちなみに自分の場合、メニューバーをクリックするとフォームが立ち上がるようにしてます。そのフォームの中に簡単な説明とボタンを配置し、ボタンをクリックすると機能が実行されるようにします。フォームごとに同系列の機能をまとめておくことで把握がしやすいですし、フォームは常に表示した状態にしておけるので機能を呼び出すのも楽になります。
Excelマクロ／VBAで始める業務自動化プログラミング入門（12）：Excelに入力フォームを作成、コントロールを追加、表示、ボタンでイベント実行 (1/3) - ＠IT
以下補助部分
*1：Function GetUserName
内容
ユーザー名を取得する。
*2：Private Sub Workbook_AddinUninstall()
ワークブック イベントプロシージャに記載。アンインストール時にメニューバーを削除。
Excel VBA 入門講座 ワークブックのイベントプロシージャ
10.3 アドインのアンインストール時 - Excel VBA Tips
*3：Private Sub Workbook_AddinInstall()
内容
ワークブック イベントプロシージャに記載。インストール時にメニューバーを追加。
【指定したフォルダ内の画像を一括でシートに表示する】【エクセル2013,VBA】
書類を作成する際に複数の画像をシートにまとめたいときのためのコード。
以下概略
ダイアログボックスで画像の入っているフォルダを選択
↓
拡張子を指定
↓
選択フォルダ内の指定された拡張子の画像がシートに貼り付けられる。
以下コード
=========================================================
Sub 画像取得v1()
'指定フォルダの画像ファイルをシートに集める。メインコード
Dim i As Long, FP As String, FN As String, SN As String, fso As Object, SaPath As String, filet As String
Application.ScreenUpdating = False
'セルサイズの調整。セルの大きさを変えたい場合はここを変更する。
Columns("A:A").ColumnWidth = 3
Columns("B:C").ColumnWidth = 15
Columns("D:D").ColumnWidth = 50
'カラムA→連番、B→ファイル名、C→作成日、D→画像
Range("A1") = "No"
Range("B1") = "FileName"
Range("C1") = "作成日"
Range("D1") = "画像"
'画像が入っているフォルダ（FN）を選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "画像が入っているフォルダを選択してください。"
If .Show = -1 Then
FN = .SelectedItems(1)
Else 'キャンセル
Exit Sub
End If
End With
'画像の拡張子を選択
filet = InputBox("拡張子を入力してください", "", ".JPG")
tst = ActiveWorkbook.Name
SN = ActiveSheet.Name
Set fso = CreateObject("Scripting.FileSystemObject")
'拡張子確認ルーチンを呼び出す
Call checkFileJPG(fso, FN, SN, filet, 2)
'見やすく書式を整える
Columns("A:D").Select
Selection.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
MsgBox "完了"
End Sub
Sub checkFileJPG(fso As Object, FilePath As String, SN As String, filet As String, totalN As Long)
'拡張子確認ルーチン。再帰式でフォルダをどんどん深くもぐってファイルが指定された拡張と同じか確認していく。
On Error Resume Next
Dim TargetFile As Object, TargetFile2 As Object, CellHight As Long
'セルの高さ設定値。画像の大きさは「セルの高さ-5」。画像の大きさを変えたい場合はここを変える。
CellHight = 165
'フォルダ内のファイルの拡張子をひとつづつチェックしていく。
For Each TargetFile In fso.getfolder(FilePath).Files
'もし拡張子が一致したら。大文字小文字関係なし設定。
If UCase(Right(TargetFile.Name, Len(filet))) = UCase(filet) Then
'セルの高さを調整
Sheets(SN).Range(Cells(totalN, 4), Cells(totalN, 1)).RowHeight = CellHight
'ファイル名等の情報を入力
Sheets(SN).Cells(totalN, 1) = totalN - 1
Sheets(SN).Cells(totalN, 2) = TargetFile.Name
Sheets(SN).Cells(totalN, 3) = TargetFile.datecreated
'画像を貼り付けを呼び出す
Call 画像挿入v1("D" & totalN, TargetFile.Path, SN, CellHight - 5)
'total→貼り付ける行
totalN = totalN + 1
End If
Next
'サブフォルダがあれば再帰式でフォルダをどんどん深くもぐっいく
For Each TargetFile2 In fso.getfolder(FilePath).SubFolders
Call checkFileJPG(fso, TargetFile2.Path, SN, filet, totalN)
Next
End Sub
Sub 画像挿入v1(CellA As String, myFileName As String, SN As String, Thight As Single)
'画像を貼り付け
Dim myShape As Shape, TH As Single, TW As Single
On Error Resume Next
'指定されたセルの左上に貼り付け
Set myShape = Worksheets(SN).Shapes.AddPicture( _
Filename:=myFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Sheets(SN).Range(CellA).Left, _
Top:=Sheets(SN).Range(CellA).Top, _
Width:=0, _
Height:=0)
'画像の大きさをセルの高さより若干小さくする。縦横比はそのまま。
With myShape
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
TH = .Height
TW = .Width
.Height = Thight
.Width = TW * Thight / TH
End With
End Sub
【改行コードの変換「LF」→「CR」】【ファイルサイズが大きな場合】【エクセル2013,VBA】
改行コードがLFでファイルサイズが大きいテキストファイルをVBAで扱う方法を説明する。
WindowsとLinuxでは、改行コードが異なる。
Windows→CRLF（キャリッジリターン＋ラインフィード）
Linux →LF（ラインフィード）
Linuxで作成したテキストファイルをエクセルVBAで利用するときに改行コードを置換したい場合があるのだがいくつ方法がある。
1.Linux側でLFをCRLFに置換する。
2.適当なソフトを使用しWindows側でLFをCRLFに置換する。
3.VBAでLFをCRLFに置換する。
今回のケースはネットからWindowsマシンに落としてきたファイル（NCBIのGeneBank形式ファイル）の改行コードがLFで、これをVBAでアクセスまたはエクセルに取り込むことが目的である。余計なステップが入るので2は除外だし、いきなりWindowsマシンなので1もない。
ファイルサイズが小さな場合
改行コードがLFだと1行しかないとみなされるので、どのような読み込み方しても結果的にはかわらないが、ふつうにLine Inputか何かで読み込んでLFをCRLFにReplaceしてしまうかLFでSplitしてしまえばよい。
LFコードで改行したファイルを読み込む：Excel VBA｜即効テクニック｜Excel VBAを学ぶならmoug
ファイルサイズが大きな場合
ファイルサイズが大きな場合、メモリが足りなくなるのでLine Inputではテキスト型に読み込めなくなる。
そこで
1.Getステートメントでバイト型配列にバイナリデータとして読み込む
2. LFをCRに置換したテキストファイルを一時的に作成
3.このファイルをLine Inputで読み込む
以上の手順でNCBIのGeneBank形式ファイルをアクセスやエクセルに取り込むことができた。
以下置換ファイルを作成するコード。ただし、本当にこれでいいのかがよくわからない。他にVBAのみで解決する簡単な方法があればご教授願いたい。いちおう300MB程度でも動作はしている。
==============================================================
Sub 置換()
Dim buffer() As Byte
Dim tmp As Variant, tmp2 As Variant
Dim i As Long
Open ファイル名1 For Binary As #1 'バイナリーで開き読み込み
ReDim buffer(1 To LOF(1)) 'ファイルのサイズ分だけ領域確保
Get #1, ,buffer 'バイト型配列に読み込み
Close #1
'バイト型配列を順に置換していく
For i = 1 to ubound(buffer)
if buffer(i)=10 then 'LFなら
buffer(i)=13 'CRに置換
End if
Next
Open ファイル名2 For Binary As #1 'バイナリーで開き書き込み
Put #1,1 ,buffer 'バイト型配列を書き込み
Close #1
'ファイル名2はLine Inputで一行ごとに読み込めるので何とでもなる。
End Sub
【セルの行高さや列幅をmmで指定する】【エクセル2013,VBA】
結論としてはセルの大きさは0.01mm単位での設定は難しいが0.1mm単位だとそれなりに近い値での設定が可能である。
エクセルの行の高さの単位はポイント、列の幅の単位は文字数となっている。「mm→ポイント」変換は用意されている関数を使えばよいので行の高さ設定について頭を悩ませることはないが、「mm→文字数」変換はフォントや環境（ディスプレー）などによって値がかわってくるのでかなりややこしい。さらに画面上でしっかり設定できたとしても、印刷の際にはプリンターに依存して微妙に大きさが変わる。これは、印刷されたセルのサイズを実際に測定し、印刷時の拡大縮小設定を調整することで対応するしかないようだ。
行の高さの設定
センチからポイントへはCentimetersToPoints関数を使用すればよい。
ただし、行の高さを手動でかえていくと、（自分の環境では）設定できる数字が0.25ポイント刻みであることがわかる。
例（9.5→9.5,9.6→9.5,9.7→9.75,9.8→9.85)
ここでいったん長さの単位のおさらい
「1ポイント=1/72インチ
1インチ=25.4mm
0.25ポイント=25.4/72/4mm=0.088...mm」
という割り切れない中途半端な数字になっている。細かくmmで指定しても、結局は0.25ポイン刻みに丸められてしまうので0.1mm程度の誤差がでてしまう。
ちなみに画面の文字は小さな点（ピクセル）の集合であり、フォントや環境により文字あたりのピクセル数が異なる。大きさはピクセルの倍数かつ変更の最小単位は1ピクセルの大きさとなる。
列の幅の単位
列の幅の単位は文字数。0が何文字表示されるかを意味している。0の幅の値は設定されているフォントの種類・大きさ、および環境（ディスプレー）によって異なってくる。
列の幅の設定
VBAではプロパティから列幅を取得する2つのメソッドがある。「Columnwidth（単位：文字数）」と「Width（単位:ポイント）」である。Widthは値の取得のみで変更・設定できず、変更・設定できるのはColumnwidthだけである。なので「mm→ポイント→文字数」へと順に変換する必要が有る。「mm→ポイント」変換は行高さと同様に行えばよい。同一環境下ではポイントと文字数の関係はどうも「Y = aX + b」であらわされる”ようだ”（Y→ポイント、X→文字数、a,b→定数）。a,bは環境により異なる。言い換えると、「一定の余白（→b) ＋ 一文字あたりの幅 （→a）X 文字数」ということらしい。a,bをどうやって求めるかだが、セルの幅を変化させ（Columnwidthに様々な値を入れる）たのち、Widthを1回ごとに取得し、それらの値をもとに計算すれば求めることができる（方法1)。また単純に最小の文字数から0.01文字（最小単位）ずつColumnwidthを増加させていきWidth値を監視し目的の幅（単位ポイント）になるまで増加させることで求めるやり方（方法2)も考えられる。方法1は数字の丸め（ピクセルの幅に調整される）が入ると微妙にずれる可能性が考えられ、方法2は力技すぎるので方法1で大体の数値を設定し方法2で微調整する方法をとることとした。くわえて方法1のとおりにaとbを求めるやり方だとゴテゴテするので若干不正確かもしれないがシンプルなコードを採用している。
===============================================================
Sub セルサイズ指定()
'
' 選択された各セルをmm単位で設定する。
Dim PointDelta As Double, EndN As Long, StepN As Long, NEARW As Double, NearD As Double, i As Long
Dim Buf As Range, tempW As Double, setteiRH As Double, setteiCW As Double, setteiCWP As Double
On Error GoTo ELH
Set Buf = Application.InputBox(PROMPT:="サイズを変更したい範囲を選択してください。", Type:=8)
Buf.Select
Application.ScreenUpdating = False
setteiRH = InputBox("各セルの行高さの設定値を入力（単位:mm)", "入力", 10) / 10
setteiCW = InputBox("各セルの列幅の設定値を入力（単位:mm)", "入力", 10) / 10
On Error GoTo ELH2
'RowHeghtを設定（高さはポイントをいれればよい。センチからポイントへはCentimetersToPoints関数を使用）
Selection.RowHeight = Application.CentimetersToPoints(setteiRH)
'setteiCWP →幅の設定値をcmからポイントへ変換
setteiCWP = Application.CentimetersToPoints(setteiCW)
'「X= (Y-b)/a」X(文字数）。bはYにくらべ十分小さく、1/aは「Selection(1).ColumnWidth / Selection(1).Width」に近い数字となる。またSelection(1).Widthと目的の値との差が小さいほどtempWが目的の値に近くなるため、ループさせることで1回ごとに正解に近づいていく。ColumnWidthの取りうる値が不連続なためだいたい3回くらいで目的の値にたどりつく。
For i = 1 To 5
tempW = setteiCWP * Selection(1).ColumnWidth / Selection(1).Width
Selection(1).ColumnWidth = tempW
Next
'ここまででほぼ完了。
'============ここから微調整のためのコード。しかし試したところ↑だけで目的の値になっていた。不要かもしれない（削除可）。===================
PointDelta = setteiCWP - Selection(1).Width
Select Case PointDelta
Case 0
Case Is < 0
EndN = -2000
StepN = -1
Case Is > 0
EndN = 2000
StepN = 1
End Select
NearD = PointDelta
NEARW = tempW
Debug.Print "差=設定値（ポイント）-実際の値（ポイント）=" & PointDelta
'0.001文字刻みで増減させていき最も設定値に近い幅を探索
For i = 0 To EndN Step StepN
Selection(1).ColumnWidth = tempW + i / 1000
If Abs(NearD) < Abs(setteiCWP - Selection(1).Width) Then
Exit For
Else
NearD = setteiCWP - Selection(1).Width
NEARW = tempW + i / 1000
End If
Next
Selection.ColumnWidth = NEARW
Debug.Print "ループした回数=" & i
Debug.Print "ループ後の差=" & NearD
'================微調整ここまで===================================
'数字が丸められた後の実際の値を表示。
MsgBox "完了" & Chr(13) & "丸められた後の幅(mm)=" & Selection(1).Width / Application.CentimetersToPoints(1) * 10 & Chr(13) & "丸められた後の高さ(mm)=" & Selection.RowHeight / Application.CentimetersToPoints(1) * 10
Application.ScreenUpdating = True
Exit Sub
ELH2:
MsgBox "設定可能な最大値を超えてるかも?"
Exit Sub
ELH:
MsgBox "終了"
End Sub
iMacデュアルディスプレイ化
やることは単純にディスプレイをつなぐだけだったのだがちょっとミス。
iMacをデュアルディスプレイ化する方法 ―実はケーブルつなぐだけの簡単設定 - NAVER まとめ
まずは以下の2点を購入
1.Thunderbolt➡HDMI変換ケーブル、980円
2.ディスプレイ「BenQGW2255」
しかし手元に届いたディスプレーをみるとHDMI端子がなくDVI端子のみ。もう一つ新しい型である「GW2255HM」は1,500円ほど高くHDMI対応であったのだが、こちらを購入したものと勘違いしていた。
ケーブルを買い直すと、GW2255とGW2255HMの価格差はひっくり返りそうな気がしたので、しっかり確認しなかったことをつよく後悔した。しかしThunderbolt➡HDMI変換ケーブルを生かすべく、調べてみると以下の品を発見！
3.HDMI DVI 変換アダプター
通常お店で買うと1,500円くらいするのだが驚きの177円。恐る恐る購入したところ、しっかり動き安さに感動した。
合計14,000円でデュアルディスプレイ化完了した。とても快適。
