エクセルマクロで、画面キャプチャしてファイルとして保管したい
現在選択されているエクセルシートをキャプチャして保管したい
Geminiに聞いてコードを書いてみて実行した。ファイルは出力されたが、中身は真っ白でした
何度かGeminiに聞いて修正したコードで試したがダメ
どこが悪いか教えて頂けると嬉しいです
Sub SaveMeasurementCapture()
Dim ws As Worksheet: Set ws = Sheets("公差表示")
Dim targetRange As Range
Dim desktopPath As String
Dim folderPath As String
Dim fileName As String
Dim fullPath As String
Dim chartObj As ChartObject
Dim titleStr As String
' --- 設定エリア ---
' 1. キャプチャしたいセル範囲を指定（必要に応じて変更してください）
Set targetRange = ws.Range("A1:K30")
' 2. デスクトップの「測定履歴」フォルダを指定
desktopPath = Environ("USERPROFILE") & "\Desktop"
folderPath = desktopPath & "\測定履歴\"
' 3. I1セルからファイル名にする文字列を取得
titleStr = ws.Range("I1").Value
If titleStr = "" Then titleStr = "NoTitle"
' 4. ファイル名の作成（I1の内容_日付_時刻.png）
fileName = titleStr & "_" & Format(Now, "yyyy-mmdd_hhmmss") & ".png"
fullPath = folderPath & fileName
' ------------------
' デスクトップに「測定履歴」フォルダがない場合は自動で作る
If Dir(folderPath, vbDirectory) = "" Then
On Error Resume Next
MkDir folderPath
On Error GoTo 0
End If
' --- 描画トラブル対策（真っ白回避） ---
Application.ScreenUpdating = True
targetRange.Select
' 範囲を画像としてコピー
targetRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' 一時的なグラフ（Chart）を作成して書き出し
Set chartObj = ws.ChartObjects.Add(0, 0, targetRange.Width, targetRange.Height)
With chartObj
.Border.LineStyle = xlNone ' 枠線を消す
.Chart.Paste
' 貼り付けが完了するまで確実に待機（1秒）
DoEvents
Application.Wait [Now() + "00:00:01"]
' 画像として保存
.Chart.Export fileName:=fullPath, FilterName:="PNG"
' 使い終わったグラフを削除
.Delete
End With
Application.ScreenUpdating = True
' 保存完了メッセージ
MsgBox "履歴画像を保存しました！" & vbCrLf & _
"フォルダ: デスクトップ\測定履歴" & vbCrLf & _
"ファイル名: " & fileName, vbInformation
End Sub
