HOME > エクセルVBA > サンプル > SpinButton

SpinButton


【ファイル名】SpinButton.xlsm
【バージョン】Ver 1.0.1.1
【作成日】2019年06月04日
【更新日】2019年06月07日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】SpinButton.zip
【説明】ユーザー フォームのSpinButtonコントロールのサンプルです。
フォーム

SpinButtonコントロール

 Minプロパティは、最小値です。
 Maxプロパティは、最大値です。
 Valueプロパティは、値です。
 SmallChangeプロパティは、増減値です。

 Changeイベントは、値を変更した処理です。
 SpinUpイベントは、「↑」ボタンの処理です。
 SpinDownイベントは、「↓」ボタンの処理です。

数値を変更する回数が多い場合は、TextBoxコントロールから入力できるようにしましょう。

TextBoxコントロール

 IMEModeプロパティは、fmIMEModeDisable にしてIMEを無効にします。
 TextAlignプロパティは、fmTextAlignRight にして右寄せにします。
 KeyPressイベントで、キーの入力の文字を制限します。引数のKeyAsciiはByValですが、ポインターなので値を変更できます。
 Changeイベントで、クリップボードから貼り付けられた不正な値を検証します。(数字以外の文字、範囲外の数値)

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="SpinButton">
          <button id="ShowFormButton" label="フォームを表示" keytip="S" supertip="SpinButtonのサンプルのフォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
Option Explicit

Const BigChange = 10 ' SpinButton1でPageUp、PageDownキーで変更する数
  
Private Sub SpinButton1_Change() ' SpinButton1の値の変更
  TextBox1.Text = SpinButton1.Value
End Sub

Private Sub SpinButton1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  If KeyCode = vbKeyPageDown Then ' 10 カウント ダウン
    KeyCode = 0
    If SpinButton1.Value - BigChange < SpinButton1.Min Then
      SpinButton1.Value = SpinButton1.Min
    Else
      SpinButton1.Value = SpinButton1.Value - BigChange
    End If
  ElseIf KeyCode = vbKeyPageUp Then ' 10 カウント アップ
    KeyCode = 0
    If SpinButton1.Value + BigChange > SpinButton1.Max Then
      SpinButton1.Value = SpinButton1.Max
    Else
      SpinButton1.Value = SpinButton1.Value + BigChange
    End If
  End If
End Sub

Private Sub SpinButton2_Change() ' SpinButton2の値の変更
  NumericLabel.Caption = SpinButton2.Value
End Sub

Private Sub SetSpinButtonValue() ' TextBox1のTextから、SpinButton1のValueに設定する
  Dim Value As Long
  
  On Error GoTo ERROR_HANDLE ' 文字列やLong型よりも大きい数値をクリップボードから貼り付けが可能のため
  Value = CLng(StrToDouble(TextBox1.Text)) ' 数値以外の文字列を除去する
  
  If Value < SpinButton1.Min Then ' 最小値よりも小さい場合は、最小値にする
    TextBox1.Text = SpinButton1.Min
    SpinButton1.Value = SpinButton1.Min
  ElseIf Value > SpinButton1.Max Then ' 最大値よりも大きい場合は、最大値にする
    TextBox1.Text = SpinButton1.Max
    SpinButton1.Value = SpinButton1.Max
  Else ' 範囲内の場合は、そのままの値にする
    SpinButton1.Value = Value
  End If
  
  Exit Sub
'---------------------------------------------------------
ERROR_HANDLE:
  MsgBox Prompt:=Err.Description, Buttons:=vbCritical, Title:="エラー"
End Sub

Private Sub TextBox1_Change() ' TextBox1の値の変更
  If TextBox1.Text = "" Then Exit Sub
  If TextBox1.Text = "-" Then Exit Sub
  
  If Not IsNumeric(StrToDouble(TextBox1.Text)) Then ' クリップボードから数値以外を貼り付けできるので、文字列を除去する
    TextBox1.SelStart = 0                           ' Valは最初の文字列は除去できない、0になる
    TextBox1.SelLength = TextBox1.TextLength
    MsgBox Prompt:="数字を入力してください。", Buttons:=vbExclamation, Title:="警告"
'    TextBox1.Text = "0" ' エラーの場合は、0にクリアーしても良いでしょう。
'    SpinButton1.Value = 0
    Exit Sub
  End If
  
  Call SetSpinButtonValue ' TextBox1のTextから、SpinButton1のValueに設定する
End Sub

Private Sub TextBox1_Enter() ' テキストボックスにTABで移動したら、すべてのテキストを選択する
  With TextBox1
    .SelStart = 0
    .SelLength = .TextLength
  End With
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) ' ↓キー、↑キーの処理
  If KeyCode = vbKeyDown Then ' カウント ダウン
    If SpinButton1.Value - SpinButton1.SmallChange < SpinButton1.Min Then
      SpinButton1.Value = SpinButton1.Min
    Else
      SpinButton1.Value = SpinButton1.Value - SpinButton1.SmallChange
    End If
  ElseIf KeyCode = vbKeyUp Then ' カウント アップ
    If SpinButton1.Value + SpinButton1.SmallChange > SpinButton1.Max Then
      SpinButton1.Value = SpinButton1.Max
    Else
      SpinButton1.Value = SpinButton1.Value + SpinButton1.SmallChange
    End If
  ElseIf KeyCode = vbKeyPageDown Then ' 10 カウント ダウン
    If SpinButton1.Value - BigChange < SpinButton1.Min Then
      SpinButton1.Value = SpinButton1.Min
    Else
      SpinButton1.Value = SpinButton1.Value - BigChange
    End If
  ElseIf KeyCode = vbKeyPageUp Then ' 10 カウント アップ
    If SpinButton1.Value + BigChange > SpinButton1.Max Then
      SpinButton1.Value = SpinButton1.Max
    Else
      SpinButton1.Value = SpinButton1.Value + BigChange
    End If
  End If
End Sub

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) ' キーの入力の文字を制限する
  If KeyAscii <> Asc("-") And KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then ' ドット(.)とプラス(+) 記号は不可
    KeyAscii = 0 ' キーの入力を無効にする
    Exit Sub
  End If ' 2個以上のマイナス記号(-)を入力できます。
  
  On Error Resume Next
  Dim Value As Long
  
  Value = CLng(TextBox1.Text)
  If Err.Number > 0 Then ' 前回にクリップボードから不正な値を貼り付けられた場合(文字列、オーバーフローの数値)
    Err.Clear
    Exit Sub
  End If
  On Error GoTo 0
End Sub

Private Sub UserForm_Initialize() ' 初期処理
  With TextBox1
    .IMEMode = fmIMEModeDisable ' IMEを無効にする
    .TextAlign = fmTextAlignRight ' 右寄せ
    .HideSelection = False ' フォーカスを失っても、選択状態を維持する
  End With
  
  With SpinButton2
    .Min = 10   ' 最小値
    .Max = 100  ' 最大値
    .Value = 50 ' 値
    .SmallChange = 10  ' 増減値
  End With
End Sub
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  Exit Sub
'-------------------------------------------------------------------------------------------------------------------------
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub

' 指定した文字が2回以上あれば削除します。
Public Function OneChar(Text As String, Optional Chars As String = "+-.") As String
  Dim i As Long
  Dim j As Long
  Dim bFind As Boolean
  Dim CharsLen As Long
  Dim c As String
  Dim s1 As String
  Dim s2 As String
  
  s1 = Text
  CharsLen = Len(Chars)
  For i = 1 To CharsLen
    bFind = False
    
    s2 = ""
    For j = 1 To Len(s1)
      c = Mid(s1, j, 1)
      If c = Mid(Chars, i, 1) Then ' 同じ文字の場合は、
        If bFind = False Then s2 = s2 + c ' 1回目はOK、2回目からは削除する
        bFind = True
      Else ' 違う文字の場合は、
        s2 = s2 + c
      End If
    Next
    
    s1 = s2
  Next
  
  OneChar = s1
End Function

' 指定した文字のみ取得します。
Public Function GetChars(Text As String, Optional Chars As String = "-.0123456789") As String
  Dim i As Long
  Dim j As Long
  Dim TextLen As Long
  Dim CharsLen As Long
  Dim c As String
  Dim s As String
  
  s = ""
  TextLen = Len(Text)
  CharsLen = Len(Chars)
  For i = 1 To TextLen
    c = Mid(Text, i, 1)
    For j = 1 To CharsLen
      If c = Mid(Chars, j, 1) Then ' 同じ文字の場合は、
        s = s & c
        Exit For
      End If
    Next
  Next
  
  GetChars = s
End Function

' 文字列からDouble型の数字に変換します。
Public Function StrToDouble(Text As String) As Double
  Dim s As String
  
  s = OneChar(GetChars(StrConv(Text, vbNarrow))) ' 半角にし、数字と1文字以下のドット記号(.)とマイナス記号(-)にする
  If InStr(1, s, "-") > 1 Then ' 先頭以外のマイナス記号(-)は削除する
    s = Replace(s, "-", "")
  End If
  
  StrToDouble = Val(s) ' 【注意】 オーバーフローになる可能性があります。
End Function
このページの上