Excel VBA質問箱 IV

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

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


21081 / 76732 ←次へ | 前へ→

【61056】Re:シートにある画像を、画像の斜め上の表に書いてある番号名で保存するマクロ
発言  Jaka  - 09/4/6(月) 17:06 -

引用なし
パスワード
   チャートオブジェクトの使い回しがうまい事行きませんでした。
よって、毎回作っちゃ削除を繰り返しています。
なのもで、新規シートを作業シートとしました。(後で削除)
素直に 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

0 hits

【61011】シートにある画像を、画像の斜め上の表に書いてある番号名で保存するマクロ ai 09/4/3(金) 0:04 質問
【61021】Re:シートにある画像を、画像の斜め上の表... Jaka 09/4/3(金) 16:31 発言
【61032】Re:シートにある画像を、画像の斜め上の表... ai 09/4/4(土) 19:20 発言
【61056】Re:シートにある画像を、画像の斜め上の表... Jaka 09/4/6(月) 17:06 発言
【61058】Re:シートにある画像を、画像の斜め上の表... ai 09/4/6(月) 18:41 お礼
【61077】ちょっと変えました。 Jaka 09/4/8(水) 13:33 発言
【61129】更に改良 Jaka 09/4/10(金) 14:58 発言
【61195】Re: ai 09/4/15(水) 20:06 お礼

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