Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


68404 / 76738 ←次へ | 前へ→

【12872】Re:ブックを開く時のパスワード設定
回答  ichinose  - 04/4/17(土) 17:49 -

引用なし
パスワード
   ▼mixi さん、かみちゃんさん、こんにちは。
>データーベースとして使っているエクセルブックを
>ボタンから開く際にパスワードを入力しないと開けなくし
>特定の人しか変更等出来ないようにしたいのですが・・・
>術が分かりませんのでご教授ください。
データベースとなるブックにパスワードを付けたらいかがですか?
パスワードは、手動操作で保存しなおせば付けられます。

仮にこのデータベースとしてのブックをsvsample.xlsとしましょう。
以下のコードでもパスワード付で保存します。
'==============================================================
Const パスワード = "ichinose" '←パスワード
Sub パスワード付保存()
  Dim retcode As Long
  retcode = save_bk(Workbooks("svsample.xls"), "D:\My Documents\TESTエリア\svsample.xls", パスワード)
  If retcode <> 0 Then
   MsgBox Error(retcode)
  Else
   MsgBox "保存されました"
   End If
End Sub
'==============================================================
Function save_bk(bk As Workbook, bk_path, Optional password = "") As Long
  On Error Resume Next
  save_bk = 0
  Application.DisplayAlerts = False
  bk.SaveAs Filename:=bk_path, password:=password, writerespassword:=password
  save_bk = Err.Number
  Application.DisplayAlerts = True
  On Error GoTo 0
End Function

**************************************************************************

次に読み込み時は、ユーザーフォーム(Userform1)でパスワードを
入力させてみましょう。

ユーザーフォーム(UserForm1)には、
  テキストボックス(TextBox1)---パスワード入力用
  コマンドボタン(CommandButton1)--「OK」ボタン
  コマンドボタン(CommandButton2)---「Cancel」ボタン
の三つのコントロールをパスワード入力フォームっぽい配置で作成して下さい。


標準モジュールに
'======================================================================
Public Type output_data
  btn As Boolean 'true : okボタンがクリック False:Cancelボタンがクリック
  pass_str As String 'btnがTrueのとき、パスワード
  End Type
'======================================================================
Sub パスワード付読込()
  Dim pass_word As output_data
  Dim openbk As Workbook
  Dim retcode As Long
  pass_word = パスワード入力()
  If pass_word.btn = True Then
   retcode = open_bk(openbk, "D:\My Documents\TESTエリア\svsample.xls", pass_word.pass_str)
   If retcode <> 0 Then
     If retcode = 1004 Then
      MsgBox "パスワードが違います"
     Else
      MsgBox Error(retcode)
      End If
   Else
     MsgBox openbk.Name & "は、オープンされました"
     End If
   End If
End Sub

'========================================================================
Function パスワード入力() As output_data
'ユーザーフォームからパスワードを入力させる
'Output パスワード入力
  Load UserForm1
  With UserForm1
   .TextBox1.PasswordChar = "*"
   .Show
   パスワード入力.btn = .ok
   パスワード入力.pass_str = .TextBox1.Text
   End With
  Unload UserForm1
End Function
'========================================================================
Function open_bk(bkobj As Workbook, bk_path, Optional password = "") As Long
'指定されたパス名のブックをオープンする
  On Error Resume Next
  open_bk = 0
  Set bkobj = Workbooks.Open(Filename:=bk_path, password:=password, _
              writerespassword:=password)
  open_bk = Err.Number
  On Error GoTo 0
End Function


'*************************************
次いでUserForm1のモジュールに
'=========================================================================
Public ok As Boolean
'=========================================================================
Private Sub CommandButton1_Click()
  ok = True
  Me.Hide
End Sub
'=========================================================================
Private Sub CommandButton2_Click()
  ok = False
  Me.Hide
End Sub
'=========================================================================
Private Sub UserForm_Activate()
  ok = False
  TextBox1.SetFocus
End Sub
'=========================================================================
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  If CloseMode = 0 Then Cancel = True
End Sub


これでプロシジャー「パスワード付読込」を実行してみて下さい。
0 hits

【12858】ブックを開く時のパスワード設定 mixi 04/4/17(土) 9:58 質問
【12863】Re:ブックを開く時のパスワード設定 かみちゃん 04/4/17(土) 13:46 回答
【12871】Re:ブックを開く時のパスワード設定 mixi 04/4/17(土) 17:35 発言
【12872】Re:ブックを開く時のパスワード設定 ichinose 04/4/17(土) 17:49 回答
【12873】Re:ブックを開く時のパスワード設定 ちん 04/4/17(土) 18:09 回答
【12875】Re:ブックを開く時のパスワード設定 ichinose 04/4/17(土) 19:03 発言
【12973】Re:ブックを開く時のパスワード設定 mixi 04/4/20(火) 16:52 お礼

68404 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free