VBA 実行時エラー 2147024893

下記のマクロを実行すると
BBB.Save のところで、実行時エラー 2147024893(8007003)が発生します。
「ショートカット"C:\Documents and Settings\ユーザー名\MyDocuments\Documents and Settings\All Users\スタート メニュー\プログラム\スタートアップ\拡張子無しのファイル名.lnk"を保存できません。」
ヘルプをみると、オ－トメーションエラー(Error440)となっています。
いろいろ調べましたが解りません。助けて下さい。


Sub 自動起動設定()
Dim AA, BB, CC, DD
Dim AAA, BBB
AA = ThisWorkbook.Path
CC = ThisWorkbook.Name
CC = Left(CC, Len(CC) - 4)
Set AAA = CreateObject("WScript.Shell")
DD = Left(AA, 2) & "Documents and Settings\All Users\スタート メニュー\プログラム\スタートアップ"
Set BBB = AAA.CreateShortcut(DD & "\" & CC & ".lnk")
BBB.targetPath = AA & "\" & ThisWorkbook.Name
BBB.Arguments = "/n,/e," & AA & "\"
BBB.WindowStyle = 1
BBB.WorkingDirectory = AA
BBB.Save
Set BBB = Nothing
Set AAA = Nothing
End Sub

No.1 ベストアンサー 回答者： cj_mover 回答日時： 2014/03/26 23:35

こんにちは。

Windowsのバージョンが異なるようなので、その分、確度の低い話になってしまいますが、
エラーは再現できました。原因については下記■■マークの辺りを読んで下さい。
ご提示のコードを修正することで期待通りに動くことは確かめましたので、
以下で、確認、修正、するべきポイントを挙げておきます。

////////////

CC = ThisWorkbook.Name
CC = Left(CC, Len(CC) - 4)

ブック名.xls　ならば、CCは "ブック名"　ですが、
ブック名.xlsx　ならば、CCは "ブック名."　（ドットが余計）になってしまいます。
Set BBB = AAA.CreateShortcut(DD & "\" & CC & ".lnk")
ここ↑の引数が、DD & "\ブック名..lnk")のように"."ドットが重なっていないか、
確認してください。
確実に"ブック名"だけを採るなら
CC = Left(CC, InStrRev(CC, ".") - 1) '★一番右にある"."のひとつ前までの文字列
のように書きます。

////////////

AA = ThisWorkbook.Path
....
DD = Left(AA, 2) & "Documents and Settings\All Users\スタート メニュー\プログラム\スタートアップ"

AAの中身は、"C:\....."とか"D:\....."等のドライブ名で始まっているフォルダパスです。
ThisWorkbookが保存されたドライブとスタートアップフォルダのドライブが同じだという前提
が有効だとすれば、ですが、Left(AA, 2)では、"\"が抜けてしまいますね。■■
たぶんこれがエラーの原因と思われます。
DD = Left(AA, 3) & "Documents .....
とか、
DD = Left(AA, 2) & "\Documents .....
なのでは？

スタートアップフォルダのドライブが勝手に変わることはないですし、
逆にThisWorkbookがどのドライブ配下にあるかは簡単に変えることが出来てしまいます。
なので、ここは、
DD = "C:\Documents and Settings\All Users\スタート メニュー\プログラム\スタートアップ"
などのようにドライブ名を含めて決め打ちした方が安全なのではないかと思いますが、如何でしょう。

////////////

念の為、スタートアップ"フォルダのパスが、実際にお使いの環境に存在しているか、
エクスプローラ等で確認しておいた方がいいかも、です。
因みに、当方の環境では、
DD = "C:\Users\ユーザー名\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup"
を指定することで、上述の修正と合わせれば、
正しくショートカットが設定できることと、
PC起動時にExcelアプリケーションとThisWorkbookが立ち上がること、
を確認しました。