| |
チャートオブジェクトの使い回しがうまい事行きませんでした。
よって、毎回作っちゃ削除を繰り返しています。
なのもで、新規シートを作業シートとしました。（後で削除）
素直に ActiveChart ってやればよかったのかも。
Dim ACWS As Worksheet, AdWS As Worksheet, OBJ As Object
Dim LT As String, BR As String, 図形右上セル As String
Dim Rgh As Double, Rgw As Double, 画像名 As String
Set ACWS = ActiveSheet
Set AdWS = Worksheets.Add
For Each OBJ In ACWS.DrawingObjects
If TypeName(OBJ) = "Picture" Then
With OBJ
LT = .TopLeftCell.Address
BR = .BottomRightCell.Address
図形右上セル = ACWS.Range(LT, BR).Rows(1).Cells(ACWS.Range(LT, BR).Rows(1).Cells.Count).Address
If ACWS.Range(図形右上セル).Row <> 1 Then
画像名 = ACWS.Range(図形右上セル).Offset(-1).Value
Else
画像名 = ACWS.Range(図形右上セル).Offset(, 1).Value 'この辺は適当。
End If
Rgh = .Height + 7
Rgw = .Width + 7
.CopyPicture Format:=xlBitmap
With AdWS.ChartObjects.Add(0, 0, Rgw, Rgh).Chart
.Paste
.ChartArea.Border.LineStyle = 0
.Export CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & 画像名 & ".jpg"
.Parent.Delete
End With
End With
End If
Next
Application.DisplayAlerts = False
AdWS.Delete
Application.DisplayAlerts = True
Set AdWS = Nothing
|
|
Jaka
- 09/4/6(月) 17:06 -
