Excel VBA 背景色をパレットウィンドウから指定する

2012年10月20日 2012年10月21日

Excelで、工程管理などを実施いている方も多いのではないでしょうか。

Ａさん Bさん Cさんが同じエクセルひな形を操作するときに、誤って別の方のブックに触ることは、避けたいところです。そこでVBAを使って簡単に背景色を変更できるようにしたいと思います。

背景色を変更することで、誤って別のブックを変更することを防ぐことができます。

実行イメージ

背景色変更をクリック

カラーパレットから選択

背景色とが変わる

今回は、2ページ目のシートの色も変わります

実現までの経緯

簡単にできると思っていたのですが、意外に苦労しました。

まずは、Google先生で調べました。Accessでは、サンプルがありましたが、Excelのサンプルは、ありませんでした。

参考サイト：Access（アクセス）VBAテクノランド色の設定ダイアログによって色を選択させる方法

そこで、この参考サイトを利用して実現しようとするが、動かず、１か所ほど変更することで無事、動作させることができました。

良かったらぜひ、ご利用ください。

実行するためには、「cmd色の変更_Click()」プロシージャを呼びだします。

?サンプルブック

ColorSelector.xlsm

ソースプログラム

Private Type ChooseColor
  lStructSize As Long
  hWndOwner As Long
  hInstance As Long
  rgbResult As Long
  lpCustColors As String
  flags As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
                                      (pChoosecolor As ChooseColor) As Long

Private Const CC_RGBINIT = &H1                '色のデフォルト値を設定
Private Const CC_LFULLOPEN = &H2              '色の作成を行う部分を表示
Private Const CC_PREVENTFULLOPEN = &H4        '色の作成ボタンを無効にする
Private Const CC_SHOWHELP = &H8               'ヘルプボタンを表示

Public Function GetColorDlg(lngDefColor As Long) As Long
'機能 ： 色の設定ダイアログを表示し、そこで選択された色のRGB値を返す
'引数 ： lngDefColor デフォルト表示する色
'返値 ： 成功時 RGB値   キャンセル時-1  エラー時 -2  （ゼロは黒なので注意）

  Dim udtChooseColor As ChooseColor
  Dim lngRet As Long

  With udtChooseColor
    'ダイアログの設定
    .lStructSize = Len(udtChooseColor)
    .lpCustColors = String$(64, Chr$(0))
    .flags = CC_RGBINIT + CC_LFULLOPEN
    .rgbResult = lngDefColor
    'ダイアログを表示
    lngRet = ChooseColor(udtChooseColor)
    'ダイアログからの返り値をチェック
    If lngRet <> 0 Then
      If .rgbResult > RGB(255, 255, 255) Then
        'エラー
        GetColorDlg = -2
      Else
        '正常終了、RGB値を返り値にセット
        GetColorDlg = .rgbResult
      End If
    Else
      'キャンセルが押されたとき
      GetColorDlg = -1
    End If

  End With

End Function
Private Sub cmd色の変更_Click()

  Cells.Interior.Color = GetColorDlg(Range("a1").Interior.Color)
  Sheets(2).Range("1:1").Interior.Color = Sheets(1).Range("a1").Interior.Color

End Sub