エクセルでカレンダーマクロの作成について

今年のカレンダーを作成していて下記のサイトを参考にさせていただき
使用したいと考えていましたが画像の取り込みにおいてエラーが発生しました。

https://www.akiratin.com/excel-vba-%e3%81%a7%e3% …
デスクトップに保存し2022年に変更しセットボタンを実行した結果
エラーが発生し、内容としては
画像取得：[Microsoft] [ODBC Excel Driver]データベースおよびオブジェクトが読み取り専用のため更新できません。
オブジェクトの変数またはWith　ブロック変数が設定されていません
と出ます。


''' 画像ファイル名取得
Private Function GetPicture(m As Integer)
On Error GoTo Err_Handler

Dim fname As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim xl_file As String
Dim sql As String
Dim curRow As Integer

'ツールメニューの参照設定'
' Microsoft ActiveX Data Objects 2.8 Library'
'チェック'
xl_file = ThisWorkbook.FullName '他のブックを指定しても良い'

Set cn = New ADODB.Connection
cn.Provider = "MSDASQL"
#If Win64 Then
' 64bit
cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
#Else
' 32bit
cn.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & xl_file & "; ReadOnly=False;"
#End If
cn.Open

Set rs = New ADODB.Recordset

sql = "SELECT 画像ファイル名 FROM [画像$]" _
& " WHERE" _
& " 月 = " & m
rs.Open sql, cn, adOpenStatic

fname = ThisWorkbook.Path & "\" & rs!画像ファイル名

rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing

GetPicture = fname
Exit Function

Err_Handler:
MsgBox "画像取得 : " & Err.Description, vbExclamation
On Error Resume Next
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing

End Function

よろしくお願いします。

No.4 回答者： Qchan1962 回答日時： 2022/01/10 20:57

持っているものをよく確認せず投稿してしまいお手数をおかけしました。

すみません。
"Tmpxxx"
"TmpVBA" & Format(Date, "yyyymmdd")　を作成していました
標準モジュール、ユーザーフォーム、クラスモジュールなどのエクスポート、インポートのコードは提示していないので.VBProject.VBComponents(oldName).Properties("_CodeName") = "Tmpxxx"　自体も不要ですね。
セキュリティなどの設定も必要になると思い、省いたのが仇になったようです。
長くなって申し訳ありませんが掲示したコードの必要部分のみに添削して再投稿します。
内容は、所謂ブックの複製ですが、1シートずつ追加する形です。シート保護には対応していません。作成した背景はモジュール、Excelブック依存の不具合で破損したブックの修復が目的で作りました。（ブックのコピーだと不具合も引き継がれた為）
全コードはモジュールなどのエクスポート、インポートのコードがありますが省きました。

Option Explicit
' Microsoft Scripting Runtime
Dim TargetBook As Workbook '処理対象ブックオブジェクト
Dim NewWorkbook As Workbook
Dim TargetName
Sub Create_NewFile() '実行プロシージャ
Dim fso As Object
Dim Target As String
Dim newPath As String
Dim Exte As Integer

Target = Application.GetOpenFilename("Excel ブック,*.xls*")
If Target = "False" Then Exit Sub
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Workbooks.Open Target
Set TargetBook = ActiveWorkbook
TargetName = ActiveWorkbook.Name

Call CopySheets_EX(TargetBook)

newPath = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\New_" & TargetName
ThisWorkbook.Activate
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.GetExtensionName(TargetName) = "xlsm" Then Exte = 52
If fso.GetExtensionName(TargetName) = "xlsx" Then Exte = 51
With NewWorkbook
.SaveAs Filename:=newPath, FileFormat:=Exte
.Close
End With
Set NewWorkbook = Nothing
With TargetBook
.Close SaveChanges:=False
End With
Set TargetBook = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub CopySheets_EX(TargetBook)
Dim j As Long: j = 0
Dim Array_sheets() As String
Dim s As Variant
TargetBook.Activate
Sheets.Select
For Each s In ActiveWindow.SelectedSheets
If s.Index <> 1 Then
ReDim Preserve Array_sheets(j)
Array_sheets(j) = s.Name
j = j + 1
End If
Next s
'＜新規にブックを追加します。＞
TargetBook.Sheets(1).Copy
Set NewWorkbook = ActiveWorkbook
If j <> 0 Then
With NewWorkbook
TargetBook.Sheets(Array_sheets).Copy , .Sheets(.Sheets.Count)
.Sheets(1).Activate
End With
End If
End Sub

＃２のお礼欄について
バージョンやセキュリティの問題でしょうか？

私のローカルでは、Lhaplus for Windows　で解凍時不具合ログあり
対象Excelを開くと修復プロセス　と言った具合で同様の事象後
更に繰り返すと同じ個所の違うエラーが返りました。

新規ブックで作成し直すと問題なく起動処理できました。
更に破損修復Bookを自前の修復ブック作成VBAで実行し出来上がった
ブックも問題なく実行出来ました。
デスクトップ、Cドライブ、Eドライブからも起動確認できましたが問題は無かったです。

＞デスクトップとマイドキュメントではできなかったので、ADODB接続（切断）が対応していないとか何かの設定の違いなのでしょうか？

このフレーズ間違えなく見覚えがありますが、、、覚えておりません

ご質問と関係のないコード掲示で申し訳ありません。
取り合えず、訂正まで。

この回答へのお礼

回答ありがとうございます。

ブックのコピーについて再掲ありがとうございます。
ブックの複製は同様に確認できました。
Command Form等もすべてモジュール以外複製されるのですね。
結果としては同様の状態が生起しデスクトップ上と一部では動きませんでした。他の場所では動きました。今後探求してみます。
ありがとうございました。

お礼日時：2022/01/10 23:21

No.3 回答者： Qchan1962 回答日時： 2022/01/09 13:04

＃２の続きです

下記内容が良く分からない場合は、忘れてください。

VBAで新規にコピーブックを作成するプロシージャです。
実行対象ファイルは破損修復後　保存したExcelBookです
（開けないブックはWorkbooks.Open Targetでエラーが返ります）

下記を新規ブックVBE標準モジュールにコピペしてください。

'要事前バインディング　参照設定
' Microsoft Visual Basic for Applications Extensibility 5.3
' Microsoft Scripting Runtime
Dim TargetBook As Workbook '処理対象ブックオブジェクト
Dim NewWorkbook As Workbook
Dim FolPath As String 'エクスポートフォルダパス（Tmp)一時的に作成され削除されます
Dim TargetName
Sub Create_NewFile() '実行プロシージャ
Dim fso As Object
Dim Target As String
Dim newPath As String
Dim Exte As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Target = Application.GetOpenFilename("Excel ブック,*.xls*")
If Target = "False" Then Exit Sub
Workbooks.Open Target
Set TargetBook = ActiveWorkbook
TargetName = ActiveWorkbook.Name
FolPath = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" & "TmpVBA" & Format(Date, "yyyymmdd")
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FolPath) Then
fso.DeleteFolder FolPath
fso.CreateFolder (FolPath)
Else
fso.CreateFolder (FolPath)
End If
' Call ExportAll(TargetBook, FolPath)
Call CopySheets_EX(TargetBook)
' Call ImportAllModule(NewWorkbook, FolPath)
newPath = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\New_" & TargetName
ThisWorkbook.Activate
If fso.GetExtensionName(TargetName) = "xlsm" Then Exte = 52
If fso.GetExtensionName(TargetName) = "xlsx" Then Exte = 51
With NewWorkbook
.SaveAs Filename:=newPath, FileFormat:=Exte
.Close
End With
Set NewWorkbook = Nothing
With TargetBook
' .SaveAs
.Close
End With
Set TargetBook = Nothing
fso.DeleteFolder FolPath
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub CopySheets_EX(TargetBook)
Dim j As Long
Dim Array_sheets() As String
Dim s As Variant
Dim oldName As String
TargetBook.Activate
' TargetName = ActiveWorkbook.Name
Worksheets.Select
For Each s In ActiveWindow.SelectedSheets
ReDim Preserve Array_sheets(j)
Array_sheets(j) = s.Name
j = j + 1
Next s
'＜新規にブックを追加します。＞
Set NewWorkbook = Workbooks.Add
'＜追加したブックの名前を取得します。＞
With NewWorkbook
oldName = .Worksheets(1).CodeName
.VBProject.VBComponents(oldName).Properties("_CodeName") = "Tmpxxx"
TargetBook.Worksheets(Array_sheets).Copy , .Worksheets(.Worksheets.Count)
.Worksheets(1).Delete
.Worksheets(.Worksheets.Count).Activate
End With
End Sub


このファイルの場合、標準モジュールなど使用していないので
不要な部分は除いています。その関係で参照設定を実行しない為、出来上がったExcelのVBEでMicrosoft ActiveX Data Objects 2.8 Libraryにチェックを入れてください。
新規ファイル（New_元ファイル名）の出力先はデスクトップです。
同じ階層にimagesフォルダを配置すれば、動くと思います。

この回答へのお礼

丁寧なブックコピーの要領について回答ありがとうございます。
実行してみましたが
プログラミングによるVisual Basic ロジェクトは信頼性に欠けますと表示され
参照設定にてMicrosoft ActiveX Data Objects 2.8 Libraryの有効で消えましたが

.VBProject.VBComponents(oldName).Properties("_CodeName") = "Tmpxxx"
の部分がインデックス有効範囲ではありませんと出ました。
デスクトップにフォルダは作成されて中断されました。

お礼日時：2022/01/10 06:53

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2022/01/09 12:48

こんにちは

＞画像がwebからのダウンロードだった
Excelもダウンロードでは無いかと思いますがどうでしょう？
暇だったので試してみました。

ダウンロードされたExcelはADODB接続（切断）が正しく出来ていない状態で圧縮し破損しているのか、何だかの不具合が含まれているようです。
解凍時のログに正しく回答できない旨、記載されました。

そこで、不具合のあるファイルは破棄して
新規ブックに記事の内容を基に作成するとおそらく期待する処理が出来ました。
記事の内容の通り必須シート　"カレンダー","画像","祝日","休日"を作成
カレンダーシート上に　
各ActiveXコントロールを作成し
オブジェクトのプロパティでオブジェクト名を設定
CommandButton1 -> cmdSetCalender -> caption:カレンダーセット
オブジェクト名は添付図参考

記事の各プロシージャをカレンダーシートモジュールに転記
作成したブックを保存し、同じ階層にimagesフォルダを配置すれば
動くと思います。

このプログラムはもう少しデバッグが必要と推測します。
On Error Resume Next
rs.Close
cn.Close
VBEでOn Errorをキーに検索し該当部分をコメントアウトして
確認した方が良いと思います。

手作業でブックを作成するのが大変な場合、VBAで作業する方法があります
コードは次に示します。

この回答へのお礼

回答ありがとうございます
＞Excelもダウンロードでは無いかと思いますがどうでしょう？
Excelもダウンロードです。

＞解凍時のログに正しく回答できない旨、記載されました。
特に記載なく解凍できました。

＞不具合のあるファイルは破棄して
＞新規ブックに記事の内容を基に作成するとおそらく期待する処理が出来ました。
破棄し新規に作成してボタンも同じように作成しても同様の状態でした。

その後デスクトップではなく、ダウンロードフォルダでの解凍及びDドライブで実行すると設定も変えず、なぜか普通に処理できました。
デスクトップとマイドキュメントではできなかったので、ADODB接続（切断）が対応していないとか何かの設定の違いなのでしょうか？

お礼日時：2022/01/10 06:35

No.1 回答者： 初心者ですが何か。 回答日時： 2022/01/07 09:35

古いＯＳの画面ですが基本は同じです。

もし画像ファイルのプロパティにある読み取り専用にチェックがあれば外してみて下さい。

https://xtech.nikkei.com/it/pc/article/NPC/20060 …

この回答へのお礼

回答ありがとうございます。プロパティの読み取り専用についてはチェックは外れております。

プロパティの属性の部分で、画像がwebからのダウンロードだったのでセキュリティが許可されていなかったのでそれを適用してもダメでした。

最初から入っていた画像についても読み込めなくなっていました。

お礼日時：2022/01/07 19:07