Excel VBA質問箱 IV

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

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


23248 / 76732 ←次へ | 前へ→

【58853】Re:mdbファイルの最適化(2)
発言  ichinose  - 08/11/14(金) 7:03 -

引用なし
パスワード
   ▼ようたん さん:
おはようございます。
確認はしていませんが
(いや、作成した時には何度も確認したはずですが、投稿前にはしてない)、

以下のコードで作動すると思います。

「Microsoft Jet and Replication Objects 2.6 Library」に参照設定を行います。


標準モジュールに

'=========================================================
Sub test()
  Dim ret As Long
  ret = chg_pass_mdb("D:\My Documents\db1.mdb", "db1", "db1")
  If ret = 0 Then
    MsgBox "ok"
  Else
    MsgBox Error(ret)
    End If
End Sub
'======================================
Function chg_pass_mdb(ByVal dbpath, o_pdw, n_pdw, Optional tmpstr = "tmp.mdw") As Long
' 機能  指定されたMDBファイルの最適化及び、パスワード変更を行う
' IN  dbpath 最適化及び、パスワード変更を行うMDBファイルのフルネーム
'     o_pdw 変更前のパスワード パスワードが元々ない場合は o_pdw=""とする
'     n_pdw 変更後のパスワード パスワードなしの場合は、 n_pdw=""とする
'     tmpstr 省略可能 最適化及び、パスワード変更処理に使われるテンポファイル名
'     指定されたMDBファイルdbpathと同じフォルダ上に一時的に作成される
'
' OUT chg_pass_mdb 0--正常終了  その他----異常終了
  On Error Resume Next
  Dim je As JRO.JetEngine
  Dim getmypath As String
  chg_pass_mdb = 0
  getmypath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(dbpath)
  If Dir(getmypath & "\" & tmpstr) <> "" Then
   Kill getmypath & "\" & tmpstr
   If Err.Number <> 0 Then
     chg_pass_mdb = Err.Number
     Exit Function
     End If
   End If
  Set je = New JRO.JetEngine
  je.CompactDatabase "Data Source=" & dbpath & ";Jet OLEDB:Database Password=" & o_pdw, _
    "Data Source=" & getmypath & "\" & tmpstr & ";" & _
    "Jet OLEDB:Database Password=" & n_pdw
  If Err.Number <> 0 Then
   chg_pass_mdb = Err.Number
  Else
   Kill dbpath
   Name getmypath & "\" & tmpstr As dbpath
   End If
  Set je = Nothing
End Function


試してみてください。

1 hits

【58852】mdbファイルの最適化(2) ようたん 08/11/14(金) 1:33 質問
【58853】Re:mdbファイルの最適化(2) ichinose 08/11/14(金) 7:03 発言
【58870】Re:mdbファイルの最適化(2) ようたん 08/11/14(金) 23:48 お礼

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