Notes

Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Option Explicit
Private HOX As Double, HOY As Double, HOZ As Double, YO As Byte
Private RE1 As Double, RE2 As Double, TH As Byte, SPA As String
Public CA As Boolean, HD As Byte, KT As Byte, NK As Byte, TG As Byte
Public UXW As Single, UYH As Single, UMT As Byte, HYJ As Byte, BSW As String, BSH As String
#If VBA7 Then
Private Declare PtrSafe Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, dwData As Any) As Long
#Else
Private Declare Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, dwData As Any) As Long
#End If

Sub mirita1()
If YO = 0 Then Call Yomi
If HD = 0 Then Call Yomi2
CA = False
UserForm1.TextBox1.Value = Round(ActiveCell.RowHeight * (10 ^ KT) _
/ (Application.CentimetersToPoints(1) * HOY)) / (10 ^ KT)
UserForm1.TextBox1.Tag = ActiveCell.RowHeight _
/ (Application.CentimetersToPoints(1) * HOY)
UserForm1.TextBox1.Value = Val(UserForm1.TextBox1.Value) * (10 ^ NK)
UserForm1.Show
If CA = True Then Unload UserForm1: Exit Sub
If IsNumeric(Val(UserForm1.TextBox1.Tag)) = False Or Val(UserForm1.TextBox1.Tag) <= 0 Then Unload UserForm1: Exit Sub
Selection.RowHeight = Application.CentimetersToPoints(UserForm1.TextBox1.Tag * HOY)
Unload UserForm1
End Sub
Sub mirita2()
Dim HO As Double, D As Double, H As Byte, T As Double
If YO = 0 Then Call Yomi
If HD = 0 Then Call Yomi2
CA = False
T = (RE1 * HOX - RE2 * HOZ) / 9
If TH = 0 Then TH = ActiveWorkbook.Styles("Normal").Font.Size
UserForm1.TextBox1.Value = Round(((Selection.ColumnWidth - RE1 * HOX) / T + 10) * (10 ^ KT)) / (10 ^ KT)
If UserForm1.TextBox1.Value < 0.32 * TH / 11 Then
UserForm1.TextBox1.Value = Round((Selection.ColumnWidth / (RE1 * HOX - T * (10 - (0.32 * TH / 11))) * (0.32 * TH / 11)) * 100) / 100
UserForm1.TextBox1.Tag = (Selection.ColumnWidth / (RE1 * HOX - T * (10 - (0.32 * TH / 11))) * (0.32 * TH / 11))
End If
UserForm1.TextBox1.Value = Val(UserForm1.TextBox1.Value) * (10 ^ NK)
UserForm1.Label1.Caption = "列幅"
UserForm1.Show
If CA = True Then Unload UserForm1: Exit Sub
If IsNumeric(Val(UserForm1.TextBox1.Tag)) = False Or Val(UserForm1.TextBox1.Tag) <= 0 Then Unload UserForm1: Exit Sub
If UserForm1.TextBox1.Tag < 0.32 * TH / 11 Then
Selection.ColumnWidth = (RE1 * HOX - T * (10 - (0.32 * TH / 11))) * UserForm1.TextBox1.Tag / (0.32 * TH / 11)
Else
Selection.ColumnWidth = RE1 * HOX - T * (10 - UserForm1.TextBox1.Tag)
End If
Unload UserForm1
End Sub
Sub Yomi()
Dim FileNo As Integer
On Error Resume Next
FileNo = FreeFile
If op_version >= 6 Then 'WindowsVista以上
SPA = Left(Application.UserLibraryPath, _
InStrRev(Left(Application.UserLibraryPath, _
Len(Application.UserLibraryPath) - 1), "")) & "ExcelData"
Else 'WindowsXPまで
SPA = Application.Path
End If
If Dir(SPA & "Miritani.ini") <> "" Then
Open SPA & "Miritani.ini" For Input As FileNo
Input #FileNo, HOX, HOY, HOZ, RE1, RE2, HD, KT, NK, TG
Close #FileNo
End If
If KT = 0 Then KT = 2
If HOX = 0 Then HOX = 1
If HOY = 0 Then HOY = 1.0989
If HOZ = 0 Then HOZ = 1
If RE1 = 0 Then RE1 = ThisWorkbook.Sheets(1).Columns(1).ColumnWidth
If RE2 = 0 Then RE2 = ThisWorkbook.Sheets(1).Columns(2).ColumnWidth
YO = 1
End Sub
Sub Yomi2()
If TH = ActiveWorkbook.Styles("Normal").Font.Size Then Exit Sub
TH = ActiveWorkbook.Styles("Normal").Font.Size
Select Case TH
Case 14
HOX = 10 / 10.15: HOY = 1.12936: HOZ = 1 / 1.05
RE1 = 39.9: RE2 = 3.5
Case 12
HOX = 10 / 10: HOY = 1.0752: HOZ = 1 / 1.02
RE1 = 46.68: RE2 = 4.13
Case 11
HOX = 10 / 10: HOY = 1.1015: HOZ = 1 / 1
RE1 = 50.75: RE2 = 4.5
Case 10
HOX = 10 / 10.06: HOY = 1.07364: HOZ = 1 / 1.02
RE1 = 55.86: RE2 = 5
Case 9
HOX = 10 / 10.1: HOY = 1.1: HOZ = 1 / 1.02
RE1 = 62: RE2 = 5.5
Case Else
HOX = 10 / 10: HOY = 1.1: HOZ = 1 / 1
RE1 = 50.75 * 11 / TH: RE2 = 4.5 * 11 / TH
End Select
End Sub
Sub setei()
Dim FileNo As Integer, H As Byte, S As String
'If MsgBox("初期設定しますか？", vbYesNo, "Excelセンチ単位") = vbYes Then
H = ActiveWorkbook.Styles("Normal").Font.Size
S = ActiveWorkbook.Styles("Normal").Font.Name
ThisWorkbook.Sheets(1).Copy
With ActiveWorkbook.Styles("Normal").Font
.Name = S
.Size = H
End With
Columns(1).ColumnWidth = 50.75 * 11 / H
Columns(2).ColumnWidth = 4.5 * 11 / H
ActiveSheet.Protect Password:="ans4o&w1mD"
ActiveSheet.EnableSelection = xlUnlockedCells
'End If
End Sub
Sub setei2()
Dim FileNo As Integer
If YO = 0 Then Call Yomi
If Range("C3").Value = "" Or Range("C4").Value = "" Or Range("D3").Value = "" Then
MsgBox "測定サイズを入力して下さい", , "Excelセンチ単位"
Exit Sub
ElseIf IsNumeric(Range("C3").Value) = False Or IsNumeric(Range("C4").Value) = False Or IsNumeric(Range("D4").Value) = False Then
MsgBox "数値として入力して下さい", , "Excelセンチ単位"
Exit Sub
ElseIf Range("C3").Value <= 0 Or Range("C4").Value <= 0 Or Range("C3").Value > 50 Or Range("C4").Value > 50 _
Or Range("D3").Value > 50 Or Range("D3").Value <= 0 Then
MsgBox "0より大きく、50以下の数値を入力して下さい", , "Excelセンチ単位"
Exit Sub
End If
HOZ = 1 / Range("D3").Value
HOX = 10 / Range("C3").Value
HOY = 10 / Range("C4").Value * 1.1
RE1 = Columns(1).ColumnWidth
RE2 = Columns(2).ColumnWidth
FileNo = FreeFile
If Dir(SPA, vbDirectory) = "" And op_version >= 6 Then
MkDir SPA
End If
Open SPA & "Miritani.ini" For Output As FileNo
Print #FileNo, HOX, HOY, HOZ, RE1, RE2, HD, KT, NK, TG
Close #FileNo
ActiveWorkbook.Close False
End Sub
Sub setei3()
Dim FileNo As Integer
If YO = 0 Then Call Yomi
If HD = 0 Then
UserForm2.OptionButton1 = True
Else
UserForm2.OptionButton2 = True
End If
If TG = 0 Then
UserForm2.CheckBox1.Value = True
Else
UserForm2.CheckBox1.Value = False
End If
UserForm2.Show
FileNo = FreeFile
If Dir(SPA, vbDirectory) = "" And op_version >= 6 Then
MkDir SPA
End If
Open SPA & "Miritani.ini" For Output As FileNo
Print #FileNo, HOX, HOY, HOZ, RE1, RE2, HD, KT, NK, TG
Close #FileNo
End Sub
Sub help()
Dim P As String
Const HH_HELP_CONTEXT = &HF
If op_version >= 6 Then 'WindowsVista以上
P = Left(Application.UserLibraryPath, _
InStrRev(Left(Application.UserLibraryPath, _
Len(Application.UserLibraryPath) - 1), "")) & "ExcelHelp"
Else 'WindowsXPまで
P = Application.Path & "ExcelHelp"
End If
Call HtmlHelp(0, P & "センチ単位.chm", HH_HELP_CONTEXT, ByVal 10&)
End Sub

Sub tool_sa()
Dim C As CommandBar, D As Object, W As Worksheet
Dim T As Integer, S1 As Shape, S2 As Shape, S3 As Shape, S4 As Shape, S5 As Shape
Call tool_de
For Each C In Application.CommandBars
If C.Name = "Cell" Then
For Each D In C.Controls
If D.Caption = "セルの書式設定(&F)..." Then T = D.Index
Next D
With C.Controls.Add(Type:=msoControlPopup, Before:=T)
.Caption = "Excelセンチ単位(&G)"
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Mirita1.mirita2"
.Caption = "列センチ単位設定(&R)"
.FaceId = 1038
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Mirita1.mirita1"
.Caption = "行センチ単位設定(&C)"
.FaceId = 1036
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Mirita1.setei3"
.Caption = "設定(&S)"
.FaceId = 329
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "ヘルプ(&Q)"
.OnAction = "Mirita1.help"
.FaceId = 983
.BeginGroup = True
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "作者ホームページ(&H)"
.OnAction = "Mirita1.nombo"
.FaceId = 1016
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "バージョン情報(&V)"
.OnAction = "Mirita1.バージョン"
.FaceId = 65
End With
End With
ElseIf C.Name = "Row" Then
T = 0
For Each D In C.Controls
If (Application.Version >= 14 And D.Caption Like "行の高さ??(&R)...") _
Or (Application.Version <= 12 And D.Caption Like "行の高さ(&R)...") Then T = D.Index
Next D
With C.Controls.Add(Type:=msoControlButton, Before:=T + 1)
.OnAction = "Mirita1.mirita1"
.Caption = "行の高さ（センチ単位）(&Q)"
.FaceId = 1036
End With
ElseIf C.Name = "Column" Then
T = 0
For Each D In C.Controls
If (Application.Version >= 14 And D.Caption Like "列の幅??(&C)...") _
Or (Application.Version <= 12 And D.Caption Like "列の幅(&C)...") Then T = D.Index
Next D
With C.Controls.Add(Type:=msoControlButton, Before:=T + 1)
.OnAction = "Mirita1.mirita2"
.Caption = "列の幅（センチ単位）(&Q)"
.FaceId = 1038
End With
End If
Next C
End Sub
Sub tool_de()
Dim C As CommandBar, D As CommandBarControl
For Each C In Application.CommandBars
If C.Name = "Cell" Then
For Each D In C.Controls
If D.Caption = "Excelセンチ単位(&G)" Then D.Delete
Next D
ElseIf C.Name = "Row" Then
For Each D In C.Controls
If D.Caption = "行の高さ（センチ単位）(&Q)" Then D.Delete
Next D
ElseIf C.Name = "Column" Then
For Each D In C.Controls
If D.Caption = "列の幅（センチ単位）(&Q)" Then D.Delete
Next D
End If
Next C
End Sub
Sub tool_sa2()
Dim C As CommandBar
Call tool_de2
With Application.CommandBars.Add
.Name = "Excelセンチ単位"
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Mirita1.mirita2"
.Caption = "列設定(&R)"
.FaceId = 1038
.Style = msoButtonIconAndCaption
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Mirita1.mirita1"
.Caption = "行設定(&C)"
.FaceId = 1036
.Style = msoButtonIconAndCaption
End With
With .Controls.Add(Type:=msoControlButton)
.OnAction = "Mirita1.setei3"
.Caption = "設定(&S)"
.FaceId = 329
.Style = msoButtonIconAndCaption
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "ヘルプ(&Q)"
.OnAction = "Mirita1.help"
.FaceId = 983
.Style = msoButtonIconAndCaption
.BeginGroup = True
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "作者ホームページ(&H)"
.OnAction = "Mirita1.nombo"
.Style = msoButtonIconAndCaption
.FaceId = 1016
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "バージョン情報(&V)"
.OnAction = "Mirita1.バージョン"
.Style = msoButtonIconAndCaption
.FaceId = 65
End With
.Visible = True
End With
End Sub
Sub tool_de2()
Dim C As CommandBar
For Each C In Application.CommandBars
If C.Name = "Excelセンチ単位" Then
C.Delete
End If
Next C
End Sub

Private Sub バージョン()
MsgBox "Excelセンチ単位.ver1.33", vbInformation, "バージョン情報"
End Sub
Sub nombo()
Dim O As Object
Set O = CreateObject("Wscript.Shell")
O.Run "http://www.officelabo.net/"
Set O = Nothing
End Sub
Private Function op_version() As Double
Dim S As String
S = Application.OperatingSystem
If InStr(1, S, "NT") >= 1 Then
op_version = Val(Right(S, Len(S) - InStr(1, S, "NT") - 1))
If op_version < 4 Then
op_version = op_version2
End If
End If
End Function
Private Function op_version2()
Dim L As Object, S As Object, O As Object, W As Variant, M As String
Set L = CreateObject("WbemScripting.SWbemLocator")
Set S = L.ConnectServer
Set O = S.ExecQuery("Select * From Win32_OperatingSystem")
For Each W In O
M = W.Version
Next W
op_version2 = Val(Split(M, ".")(0))
End Function
-----------------------------------------------------------------------------
Rem Attribute VBA_ModuleType=VBAFormModule
Option VBASupport 1



Option Explicit
Dim B As Boolean
Private Sub CommandButton1_Click()
UserForm1.Hide
End Sub

Private Sub CommandButton2_Click()
CA = True
UserForm1.Hide
End Sub

Private Sub TextBox1_Change()
If NK = 0 Then
TextBox1.Tag = TextBox1.Value
Else
TextBox1.Tag = Val(TextBox1.Value) / 10
End If
End Sub

Private Sub UserForm_Activate()
TextBox1.SetFocus
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Value)
End Sub

Private Sub UserForm_Initialize()
If NK = 1 Then
Label2.Caption = "ミリ"
End If

End Sub
---------------------------------------------------
Rem Attribute VBA_ModuleType=VBAFormModule
Option VBASupport 1



Option Explicit

Private Sub CheckBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
TG = Not CheckBox1.Value
If CheckBox1.Value = True Then
Call mirita1.tool_sa2
Else
Call mirita1.tool_de2
End If
End Sub

Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then
HD = 0
Else
HD = 1
End If
If OptionButton3.Value = True Then
NK = 0
Else
NK = 1
End If
KT = SpinButton1.Value
Unload UserForm2
If HD = 1 Then Call setei
End Sub

Private Sub CommandButton2_Click()
Unload UserForm2
End Sub
Private Sub OptionButton3_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Label4.Caption = SpinButton1.Value
End Sub

Private Sub OptionButton4_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Label4.Caption = SpinButton1.Value - 1
End Sub

Private Sub SpinButton1_Change()
If OptionButton3.Value = True Then
Label4.Caption = SpinButton1.Value
Else
Label4.Caption = SpinButton1.Value - 1
End If
End Sub

Private Sub UserForm_Initialize()
SpinButton1.Value = KT
If NK = 0 Then
OptionButton3.Value = True
Label4.Caption = KT
Else
OptionButton4.Value = True
Label4.Caption = KT - 1
End If
End Sub