項目

ユーザーフォームにファイルドロップのイベントを実装する

内容説明

ユーザーフォームにファイルドロップのイベントはありません。
標準で備わっていないファイルのドラッグ&ドロップ等のイベントを実装するCEventFormクラスを提供します。
モードレスのユーザー フォームにも対応しています。
ソース公開のkEventsForm101.lzhをダウンロードして機能をお試し下さい。
ユーザーフォームに独自イベント[CEventFormクラス]　Version 1.01
kEventsForm101.lzh(ソース公開)のダウンロード
提供するVBAプログラムはソース公開です。自身のプログラムへの組込みを許諾します。
但し、ソースコードのWEBや書籍などへの投稿、掲載は禁止とさせて頂きます。
CEventFormクラスの仕様はkEventsForm101.lzhを任意のフォルダ(kEventsForm等)へ解凍しkEventsForm.txt(説明ファイル)をご覧下さい。
注： 提供VBAプログラムは E03M149 ユーザーフォームにマウスホイールのイベントを実装する と同じものです。

■ファイルドロップの組込み例
自身のプログラムへのCEventFormクラスの組込みは非常に簡単です。
・必要なモジュールである CEventForm.cls と MEventForm.bas をインポート
・UserFormモジュールへ以下を記述(TextBox1を配置)

Option Explicit
Private WithEvents Form As CEventForm

'CEventFormクラスを開始
Private Sub UserForm_Activate()
  '
  If Form Is Nothing Then
    Set Form = New CEventForm
    Form.Initialize Me
  End If
End Sub

'CEventFormクラスを終了
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Form.Terminate
End Sub

'FormオブジェクトのDropFilesプロシージャ
'ドラッグ&ドロップされたファイル名をTextBox1に表示する例
Private Sub Form_DropFiles(ByVal DropFile As String)
On Error Resume Next
  Static nn&
  If InStr(TextBox1.Value, DropFile) Then Beep: Exit Sub
  nn = nn + 1
  TextBox1 = TextBox1 & nn & ": " & DropFile & vbNewLine
End Sub

項目

ユーザーフォームにマウスホイールのイベントを実装する

内容説明

ユーザーフォームにマウスホイールのイベントはありません。
標準で備わっていないマウスホイール等のイベントを実装するCEventFormクラスを提供します。
モードレスのユーザー フォームにも対応しています。
ソース公開のkEventsForm101.lzhをダウンロードして機能をお試し下さい。
ユーザーフォームに独自イベント[CEventFormクラス]　Version 1.01
kEventsForm101.lzh(ソース公開)のダウンロード
提供するVBAプログラムはソース公開です。自身のプログラムへの組込みを許諾します。
但し、ソースコードのWEBや書籍などへの投稿、掲載は禁止とさせて頂きます。
CEventFormクラスの仕様はkEventsForm101.lzhを任意のフォルダ(kEventsForm等)へ解凍しkEventsForm.txt(説明ファイル)をご覧下さい。


■マウスホイールイベントの組込み例
自身のプログラムへのCEventFormクラスの組込みは非常に簡単です。
・必要なモジュールである CEventForm.cls と MEventForm.bas をインポート
・UserFormモジュールへ以下を記述(ListBox1を配置)

Option Explicit
Private WithEvents Form As CEventForm

'CEventFormクラスを開始
Private Sub UserForm_Activate()
  '
  If Form Is Nothing Then
    Set Form = New CEventForm
    Form.Initialize Me
  End If
End Sub

Private Sub UserForm_Initialize()
  Dim ii&
  For ii = 1 To 100
    ListBox1.AddItem ii
  Next
End Sub

'CEventFormクラスを終了
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Form.Terminate
End Sub

'FormオブジェクトのMouseWheelプロシージャ
'ListBoxとComboBoxのマウスホイール対応の例
Private Sub Form_MouseWheel(ByVal Control As MSForms.Control, ByVal wParam As Long, ByVal Shift As Long)
On Error Resume Next
  Dim scroll&
  Const MINS = 4, MAXS = MINS * 4
  Select Case TypeName(Control)
  Case "ListBox", "ComboBox"
    scroll = IIf(Shift, MAXS, MINS)
    With Control
      If TypeOf Control Is MSForms.ComboBox Then .DropDown
      .TopIndex = .TopIndex - Sgn(wParam) * scroll  
    End With
  End Select
End Sub

項目

ブックを開かずに読み取りパスワードが設定されているか調べる

内容説明

ブックを開かずに読み取りパスワードが設定されているか調べるkHasPasswordNotOpen関数を示します。
参照設定を要しない事後バインディングによるDAOを用いた簡単な記述になるようにしました。


'標準モジュール
Option Explicit
Option Private Module

'kHasPasswordNotOpen関数
'ブックを開かずに読み取りパスワードが設定されているか調べる
'引数 FullName：調べるブックのフルネーム
'戻り値：True=読み取りパスワードが設定されている　False=設定されていない
Function kHasPasswordNotOpen(ByVal FullName As String) As Boolean
 If Dir(FullName) = "" Then Exit Function
 On Error Resume Next
 With CreateObject("DAO.DBEngine.36").Workspaces(0).OpenDatabase(FullName, False, False, "Excel 8.0")
    If Err Then kHasPasswordNotOpen = True
    .Close
  End With
End Function

Sub test_kHasPasswordNotOpen()
 Dim ful$
 ful = "c:\ddd\eee\fff\Book1.xls"
 If kHasPasswordNotOpen(ful) Then _
   MsgBox Dir(ful) & vbCr & "読み取りパスワードは設定されています"
End Sub

なお、開いているブックの読み取りパスワード設定の状態を取得するには、
HasPasswordプロパティ が用意されています。
使用例
　Debug.Print ActiveWorkbook.HasPassword

項目

オートシェイプで扇形・円弧を描く

内容説明

オートシェイプで扇形・円弧を描く汎用のkAddSector関数を示します。
角度(既定値=180°)や開始角度(既定値=0°)を任意に指定して簡単に扇形・円弧を描く事が出来ます。

'標準モジュール
Option Explicit

'kAddSector関数
'オートシェイプで半円を描く
'引数 xx, yy:中心座標 ポイント単位
'     rr    :半径 ang1:円弧の角度(°) ang2:円弧の開始角度(°)
'　   Sector:1(既定値):扇形(線有り) 0:円弧(線無し)
'　   Sh    :描画するワークシート 既定値=ActiveSheet
'戻り値 描画した半円のShapeオブジェクト
Function kAddSector(ByVal xx#, ByVal yy#, ByVal rr#, Optional ByVal ang1# = 180, Optional ByVal ang2! = 0, Optional ByVal Sector As Long = 1, Optional ByVal Sh As Worksheet) As Shape
  If Sh Is Nothing Then Set Sh = ActiveSheet
  Set kAddSector = Sh.Shapes.AddShape(msoShapeBlockArc, xx - rr, yy - rr, rr * 2, rr * 2)
  With kAddSector
    If Val(Application.Version) < 12 Then
      .Adjustments.Item(1) = (180 + ang1) / 2 - 360
      .Adjustments.Item(2) = IIf(Sector, 0, 0.5) '0.5:線無し 0:有り
      .IncrementRotation (180 - ang1) / 2 - ang2
    Else
      .Adjustments.Item(1) = 360 - ang1 - ang2
      .Adjustments.Item(2) = -ang2
      .Adjustments.Item(3) = IIf(Sector, 0.5, 0) '0:線無し 0.5:有り
    End If
  End With
End Function

'kAddSector関数のテスト
Sub test_kAddSector()
  Dim xx#, yy#, rr#, ang1#, ang2#, Sector&
  Dim arc As Shape
  With ActiveCell
    xx = .Left: yy = .Top: rr = .Width
  End With
  ang1 = 270
  ang2 = -45
  Sector = 1
  Set arc = kAddSector(xx, yy, rr, ang1, ang2, Sector)
  'arc.Fill.ForeColor.RGB = vbCyan
End Sub

項目

ハイパーリンクでマクロを実行するには

内容説明

ハイパーリンクはファイルやWebページへ(開き)ジャンプする機能ですが、OnActionプロパティのようにマクロ(プロシ−ジャ)を登録し実行する事は出来ません。
出来なければ出来るように工夫をすると言う事で "ハイパーリンクでマクロを実行する" 手段をご紹介します。
拙作、k茶の [セルのハイパーリンクへマクロ登録]コマンドを使うとハイパーリンクに対して[マクロの登録]が出来ます。
お茶ですよ[k茶] エクセルVBA開発ツール
メニュー[ツール]-[k茶]-[セルにチップテキスト]-[セルのハイパーリンクへマクロ登録]コマンド


サンプルファイルを用意しましたので、ハイパーリンクでマクロを実行する機能をご確認下さい。
kHyperlinkOnAction.xlsのダウンロード
■[k茶]-[セルにチップテキスト]コマンドの他機能も合わせてご覧頂けます。
・チップテキスト付きのボタン作成
・セルにチップテキスト設定
・オートシェイプにチップテキスト

項目

ユーザーフォームのテキストボックスにコピー&貼り付け等の右クリックショトカットメニューを付加する

内容説明

ユーザーフォームのテキストボックスにコピー&貼り付け等の右クリックショトカットメニューを付加するクラス[CRightClick] をご紹介します。
対応コントロール：[テキストボックス]、[コンボボックス]
メニュー項目　　 ：[切り取り]、[コピー]、[貼り付け]、[削除]、[すべて選択]
使い方は非常に簡単で、CRightClickクラスのインスタンスを作成し Initializeメソッドを呼ぶだけです。

'UserFormモジュールの記述例
Option Explicit
Private Sub UserForm_Initialize()
  Static dcp As New CRightClick
  dcp.Initialize Me
End Sub

'CRightClick クラスモジュール
Option Explicit
Public WithEvents Tb As MSForms.TextBox
Public WithEvents Cb As MSForms.ComboBox
Private WithEvents BCut  As Office.CommandBarButton
Private WithEvents BCopy As Office.CommandBarButton
Private WithEvents BPaste As Office.CommandBarButton
Private WithEvents BDelete As Office.CommandBarButton
Private WithEvents BAll As Office.CommandBarButton
Dim dbox As Collection

Private Sub BAll_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  Dim bx As Object
  If TypeName(Tb) = "TextBox" Then Set bx = Tb Else Set bx = Cb
  With bx
    .SelStart = 0
    .SelLength = Len(.Value)
  End With
End Sub
Private Sub BCopy_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.Copy Else Cb.Copy
End Sub
Private Sub BCut_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.Cut Else Cb.Cut
End Sub
Private Sub BDelete_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.SelText = "" Else Cb.SelText = ""
End Sub
Private Sub BPaste_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  If TypeName(Tb) = "TextBox" Then Tb.Paste Else Cb.Paste
End Sub

Private Sub Cb_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 And Cb.Style = fmStyleDropDownCombo Then pCopyPaste Cb
End Sub
Private Sub Tb_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then pCopyPaste Tb
End Sub

Sub Initialize(fm As Object)
  Dim cc As CRightClick, bx As Object
  On Error Resume Next
  Set dbox = New Collection
  For Each bx In fm.Controls
    Select Case TypeName(bx)
    Case "TextBox", "ComboBox"
      Set cc = New CRightClick
      If TypeName(bx) = "TextBox" Then Set cc.Tb = bx Else Set cc.Cb = bx
      dbox.Add cc
    End Select
  Next
End Sub
Private Sub pCopyPaste(bx As Object) 'Copy&Paste右クリックメニュー
  With Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
    Set BCut = .Controls.Add(msoControlButton)
    With BCut
      .Caption = "切り取り(&T)"
      .FaceId = 21
      .Enabled = bx.SelLength
      If bx.Locked Then .Enabled = False
    End With
    Set BCopy = .Controls.Add(msoControlButton)
    With BCopy
      .Caption = "コピー(&C)"
      .FaceId = 19
      .Enabled = bx.SelLength
    End With
    Set BPaste = .Controls.Add(msoControlButton)
    With BPaste
      .Caption = "貼り付け(&P)"
      .FaceId = 22
      .Enabled = bx.CanPaste
    End With
    Set BDelete = .Controls.Add(msoControlButton)
    With BDelete
      .Caption = "削除(&D)"
      .FaceId = 47
      .Enabled = bx.SelLength
      .BeginGroup = True
    End With
    Set BAll = .Controls.Add(msoControlButton)
    With BAll
      .Caption = "すべて選択(&A)"
      .Enabled = Len(bx.Value)
    End With
    .ShowPopup
    .Delete
  End With
End Sub

注： クラス[CRightClick]について
このクラスは拙作、カレンダーによる日付設定 [k可憐] にて用いているクラスモジュールの一つです。要望が多いためTipsとして公開致します。
カレンダーによる日付設定 [k可憐](ソース公開)

項目

図形描画の名前の通し番号を初期化する

内容説明

図形描画(埋込グラフ等を含む)の名前は作成順に "Rectangle 1"、"Oval 2"、"AutoShape 3" 等と通し番号が付きます。
ここで通し番号の1〜3のSapeを削除しても、次に図形描画を行うと "Line 4"、"Picture 5" 等と以前の通し番号に連続して番号が付きます。
この名前の通し番号を初期化する kShapeNameNumbersInit関数を示します。

'kShapeNameNumbersInit関数
'ActiveSheetの図形描画の名前の通し番号を初期化する
Sub kShapeNameNumbersInit()
  Dim na$, cna$, ws As Worksheet
  With ActiveSheet
    na = .Name: cna = .CodeName
    .Copy Before:=Sheets(.Index)
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
  End With
  Set ws = ActiveSheet
  With ws
    .Name = na: .[_CodeName] = cna
  End With
End Sub

項目

セルや図形描画の色にウィンドウのシステムカラーを使う

内容説明

セルや図形描画の色にウィンドウのシステムカラーを使うための kChangeColorSys関数を示します。
たとえばセルの色をメニューの表面色と同じにしたい場合を考えてみましょう。
メニューの表面色と似たColorIndexプロパティを探して設定しても、その場しのぎで解決にはなりません。 メニューの表面色やボタンの表面色などのウィンドウのシステムカラーはユーザーが[画面のプロパティ]で任意に設定するもので決まった色ではありません。
色パレット(ColorIndex)をシステムカラーの色に変更する kChangeColorSys関数を用いるとシステムカラーの色を ColorIndexプロパティやSchemeColorプロパティで用いる事が出来ます。

'標準モジュール
Option Explicit
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'システムカラーのインデックス(色番号0〜24(&H18))
'Const COLOR_SCROLLBAR = 0       'スクロールバー
'Const COLOR_BACKGROUND = 1      'デスクトップ
'Const COLOR_ACTIVECAPTION = 2   'アクティブタイトルバー
'Const COLOR_INACTIVECAPTION = 3 '非アクティブタイトルバー
'Const COLOR_MENU = 4            'メニューバー
'Const COLOR_WINDOW = 5          'ウィンドウの背景
'Const COLOR_WINDOWFRAME = 6     'ウィンドウの枠
'Const COLOR_MENUTEXT = 7        'メニューの文字
'Const COLOR_WINDOWTEXT = 8      'ウィンドウの文字
'Const COLOR_CAPTIONTEXT = 9     'アクティブタイトルバーの文字
'Const COLOR_ACTIVEBORDER = &HA  'アクティブウィンドウの境界
'Const COLOR_INACTIVEBORDER = &HB '非アクティブウィンドウの境界
'Const COLOR_APPWORKSPACE = &HC  'アプリケーションの作業域
'Const COLOR_HIGHLIGHT = &HD     '強調表示
'Const COLOR_HIGHLIGHTTEXT = &HE '強調表示された文字列
'Const COLOR_BTNFACE = &HF       'ボタンの表面
'Const COLOR_BTNSHADOW = &H10    'ボタンの影
'Const COLOR_GRAYTEXT = &H11     '淡色表示された文字列
'Const COLOR_BTNTEXT = &H12      'ボタンの文字
'Const COLOR_INACTIVECAPTIONTEXT = &H13 '非アクティブタイトルバーの文字
'Const COLOR_BTNHIGHLIGHT = &H14 'ボタンの強調表示
'Const COLOR_3DDKSHADOW = &H15   'ボタンの影(濃)
'Const COLOR_3DLIGHT = &H16      'ボタンの影(淡)
'Const COLOR_INFOTEXT = &H17     'ツールヒントの文字
'Const COLOR_INFOBK = &H18       'ツールヒント

'kChangeColorSys関数
'色パレット(ColorIndex)をシステムカラーの色に変更
'引数
'　nIndex：システムカラーのインデックス(色番号0〜24(&H18))。省略値はCOLOR_BTNFACE(&HF)。-1=色パレットを既定の色に戻す
'　cIndex：変更するColorIndexプロパティの番号(1〜56)。省略値は50
'　Wb：色パレットの変更を行うワークブック。省略値はActiveWorkbook
'戻り値：cIndexの値
Function kChangeColorSys(Optional ByVal nIndex As Long = &HF, Optional ByVal cIndex As Long = 50, Optional ByVal Wb As Workbook) As Long
  If Wb Is Nothing Then Set Wb = ActiveWorkbook
  With Wb
    If nIndex = -1 Then
      .ResetColors
    Else
      .Colors(cIndex) = GetSysColor(nIndex)
    End If
    kChangeColorSys = cIndex
  End With
End Function

'■kChangeColorSys関数の使用例
'セルの色をメニューの表面色と同じにする
Sub test1_kChangeColorSys()
  Dim idx&
  idx = kChangeColorSys() 'kChangeColorSys関数を1度だけ実行
  Range("A1:R1").Interior.ColorIndex = idx '後はColorIndexプロパティにidxを設定
End Sub

'図形描画[四角形]の色をCommandButtonのBackColorの規定値[ボタンの表面色]にする
Sub test2_kChangeColorSys()
  Dim idx&
  idx = kChangeColorSys()
  With ActiveSheet.Shapes("Rectangle 1") '図形描画の[四角形]
    .Fill.ForeColor.SchemeColor = idx + 7 '+7はColorIndexプロパティからの変換値
    .Line.ForeColor.SchemeColor = idx + 7
  End With
End Sub

注： デザイン時にkChangeColorSys関数を用いた場合の処置
Workbook_Openイベント等で kChangeColorSys関数の引数nIndex、cIndex、Wb を適切に指定して実行の事。

'Openイベントでの処置例
Private Sub Workbook_Open()
  kChangeColorSys
End Sub

項目

ユーザーフォームのコントロールとイベントを動的に作成

内容説明

予め空のユーザーフォームを1つ作っておいて、場面に応じてコントロールとイベントを動的に作成し処理する方法です。
ユーザーフォームはオブジェクト名を FGeneral に変更し次のマクロを記述しておきます。 プロパティは全て初期状態のままです。
準備はこれだけです。基本的にユーザーフォームFGeneralにはコードの追加はしません。 (WithEventsキーワードやCollection等の追加は別。必要に応じ追加要)
なぜなら、追加するなら汎用的で無くなるし何も動的にする必要性が無くなります。
場面に応じた各処理は後に示す例のように他のモジュールへ記述します。

'UserForm（FGeneral）モジュール
Option Explicit
Public WithEvents CommandOK As MSForms.CommandButton
Public WithEvents CommandCancel As MSForms.CommandButton
Public txtBoxes As Collection 'TextBox

Private Sub CommandCancel_Click()
  Unload Me
End Sub

Private Sub CommandOK_Click()
  Hide
End Sub

ユーザーフォーム(FGeneral)の使用例
パスワード入力処理の例です。

'標準モジュール
Option Explicit
Option Private Module

'動的なパスワード入力ダイアログ
Sub testDynamicPasswordDdialog()
  Dim ctl As MSForms.Control, txt$
  With FGeneral '←UserFormオブジェクト
    .Width = 184: .Height = 67
    .Caption = "ライセンス登録"
    With .Controls.Add("Forms.Label.1")
      .Caption = "パスワード(P)"
      .Accelerator = "P"
      .Height = 10: .Left = 6: .Top = 6: .Width = 72
    End With
    Set .txtBoxes = New Collection
    Set ctl = .Controls.Add("Forms.TextBox.1")
    .txtBoxes.Add ctl
    With ctl
      .Height = 16: .Left = 6: .Top = 20: .Width = 100
      .PasswordChar = "*"
    End With
    Set .CommandOK = .Controls.Add("Forms.CommandButton.1")
    With .CommandOK
      .Caption = "OK"
      .Default = True
      .Height = 17.5: .Left = 115: .Top = 5: .Width = 60
    End With
    Set .CommandCancel = .Controls.Add("Forms.CommandButton.1")
    With .CommandCancel
      .Caption = "キャンセル"
      .Cancel = True
      .Height = 17.5: .Left = 115: .Top = 27: .Width = 60
    End With
    .Show
    If Not .txtBoxes Is Nothing Then
      '↓OKボタンが押された時の処理
      txt = Trim(.txtBoxes(1))
      If txt <> "" Then
        MsgBox "入力されたパスワード" & vbCr & txt, , .Caption
      End If
      Unload .ActiveControl.Parent
    End If
  End With
End Sub

項目

InputBox関数でプレースホルダ(*)文字を表示する

内容説明

InputBox関数でパスワードが入力できるようにプレースホルダ(*)文字を表示する方法です。
プレースホルダとはセキュリティ上の理由から入力文字の代わりに使われる文字です。
例えばユーザーがパスワードを入力すると、入力されたそれぞれの文字の代わりにアスタリスク(*)が表示されます。

'標準モジュール
Option Explicit
Option Private Module
Private Declare Function SetTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
  (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
  (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const EM_SETPASSWORDCHAR = &HCC
Private dtitle$, dpasschar$

Private Function pInputPasswordProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
  KillTimer 0, idEvent
  hWnd = FindWindow("#32770", dtitle)
  Call SendDlgItemMessage(hWnd, &H1324, EM_SETPASSWORDCHAR, Asc(dpasschar), &H0)
End Function

'kInputPassword関数
'パスワードが入力できるInputBox関数。InputBox関数でプレースホルダ(*)文字を表示します。
'引数
'　Prompt〜Context：InputBox関数と同じ
'　PasswordChar　 ：実際に入力された文字の代わりに表示するプレースホルダ文字。省略値は"*"
'戻り値　入力された文字列 0文字列("")：キャンセル又は文字が入力されていない
Function kInputPassword(ByVal Prompt$, Optional ByVal Title$ = "パスワード入力", Optional ByVal Default$, Optional ByVal xpos& = -1, Optional ByVal ypos& = -1, Optional ByVal HelpFile$, Optional ByVal Context&, Optional ByVal PasswordChar = "*") As String
  dtitle = Title
  dpasschar = PasswordChar
  SetTimer 0, 0, 0, AddressOf pInputPasswordProc
  If xpos < 0 Or ypos < 0 Then
    kInputPassword = InputBox(Prompt, Title, Default, , , HelpFile, Context)
  Else
    kInputPassword = InputBox(Prompt, Title, Default, xpos, ypos, HelpFile, Context)
  End If
End Function

'kInputPassword関数の使用例
Sub test1_kInputPassword()
  Const TIT = "***の解除"
  Dim ss$
  ss = kInputPassword("パスワードを入力してください。" & vbCr & vbCr & _
    "注意：パスワードは他人に知られないように注意してください。" & vbCr & _
    "パスワードは安全な場所に保管することをお勧めします。" & vbCr & vbCr & _
    "パスワード", TIT) ', PasswordChar:="+")
  If ss <> "" Then MsgBox "入力されたパスワード= " & ss, , TIT
End Sub

追記1： ユーザーフォームでパスワード入力
ユーザーフォームでパスワードを入力するためにプレースホルダ(*)文字を表示させるにはTextBoxのPasswordCharプロパティに"*"を設定すれば済みます。
簡単にパスワードのみを入力するためのユーザーフォームの例
E03M142 ユーザーフォームのコントロールとイベントを動的に作成

追記2： ワークシートのセルでパスワード入力
セルでパスワードを入力するためにプレースホルダ(*)文字を表示させる一寸面白い方法です。
手順


• 以下に示すマクロコードを対象のワークシートモジュールへ貼り付ける。
  
• 定数 dPASSADR にパスワード入力セルのアドレスを設定。
  定数 dPASSLNK に セルとリンクするときのリンク先アドレス(非表示シートのセル)を設定。リンクしない場合は""。
  
• 始めに一度だけAddTextPassword関数を実行して保存する。
  以上で準備は完了。
  
• 入力したパスワードの取得
  リンクした場合はリンク先セルの値、
  リンクしていない場合は
  　Sheet1.TextPassword.Value
  (Sheet1は対象シートのオブジェクト名)

  '対象のシートモジュール
  Option Explicit
  Const dPASSADR = "b2"            'パスワード入力セルのアドレス
  Const dPASSLNK = "" '"Sheet3!B2" 'セルとリンクするとき指定
  Const dPASSOBJ = "TextPassword"  'パスワード入力オブジェクトの名前
  
  'パスワード入力セルの作成
  '始めに一度だけ実行して保存しておく事
  Sub AddTextPassword()
    Dim rg As Range ', tb As OLEObject
    If IsObject(Evaluate(dPASSOBJ)) Then OLEObjects(dPASSOBJ).Delete
    Set rg = Range(dPASSADR)
    With ActiveSheet.OLEObjects.Add(ClassType:="Forms.TextBox.1", _
      Left:=rg.Left + 0.8, Top:=rg.Top + 0.8, Width:=rg.Width - 0.8, Height:=rg.Height - 0.8)
      .Name = dPASSOBJ
      If dPASSLNK <> "" Then .LinkedCell = dPASSLNK
      .Object.SpecialEffect = fmSpecialEffectFlat
      .Object.PasswordChar = "*"
    End With
  End Sub
  
  Private Sub TextPassword_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Select Case KeyCode
    Case vbKeyReturn
      Range(dPASSADR).Activate: SendKeys "{ENTER}"
    Case vbKeyTab
      Range(dPASSADR).Activate: SendKeys "{TAB}"
    Case vbKeyDown
      Range(dPASSADR).Activate: SendKeys "{DOWN}"
    Case vbKeyUp
      Range(dPASSADR).Activate: SendKeys "{UP}"
    End Select
  End Sub
  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address = Range(dPASSADR).Address Then _
      OLEObjects("TextPassword").Activate
  End Sub