[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『2003で使えていたマクロが2010で使用できず困っています。』（もじゃ夫）
撮影した複数の写真をエクセル上の一覧に自動的に貼り付けするためのマクロで、
他の方が作ったものですが、非常に重宝していました。
エクセルが2010となり、使ってみると
「実行時エラー1004 WorksheetクラスのPasteSpecialメソッドが失敗しました。」
というコメントが出て、デバッグすると
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
というコードの部分が黄色なります。
ちなみに写真の数枚は貼り付けられ、途中で止まる症状です。
下記にコード全文掲載致しますので、どなたか正しく動く様に書き換えて
頂けないでしょうか。
Option Base 1
Sub Photo_All_Paste()
Dim MY_Openfile As Variant
Dim MY_Pictfile() As Variant
Dim My_Width As Double
Dim My_Height As Double
Dim My_Ans As Variant
Dim My_Flg As Integer
Dim My_Str As Variant
Dim My_cell As String
Dim a As Variant, b As Variant, c As Variant
Dim i As Integer, j As Integer, k As Variant
'************
ChDir ActiveWorkbook.Path
My_Width = ActiveCell.Width '初期値は、216
My_Height = ActiveCell.Height '初期値は、162.75
My_Flg = 0
'If Not (My_Width >= 206.25 And My_Height >= 156) Then
If Not (My_Width >= 194.4 And My_Height >= 156) Then 'DELﾏｼﾝ向けに修正
MsgBox "この位置には写真を貼り付け出来ません。" & Chr(10) & Chr(10) & _
"写真を貼り付けるのに十分な大きさのセル（例．Ａ３セル等）を" & Chr(10) & Chr(10) & _
"再度クリックしてから、このボタンを押して下さい。", 16
Exit Sub
End If
My_Ans = MsgBox("今クリックされているセルは ＜" _
& ActiveCell.Address(rowabsolute:=False, columnabsolute:=False) _
& "セル＞ ですが、ここから順に右に写真を貼り付けします（１行には最大４枚として）" _
& Chr(10) & Chr(10) & "次の画面で写真のあるフォルダを指定し、" & _
"その中のどれか１枚の写真を指定して下さい。" & Chr(10) & Chr(10) & _
"そのフォルダ内にある写真が一括して全部貼り付けられます。（尚、貼り付けされる順番はファイル名の順番です）" & Chr(10) & Chr(10) & _
"貼り付けを行いますか？", 36, "写真一括貼り付けツール")
If My_Ans = vbNo Then '「いいえ」と応答した場合
Exit Sub
End If
If Application.GetOpenFileName() = False Then '「ファイルを開く」のダイアログボックスを開く
Exit Sub
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False '実行中の画面推移の抑制
'ファイルの数を調べる
MY_Openfile = Dir(CurDir() & "\*.*") 'ファイル名のみを「MY_Openfile」に格納
Do While MY_Openfile <> "" 'ファイルがあるまで繰り返す
If UCase(Right(MY_Openfile, 3)) = "JPG" _
Or UCase(Right(MY_Openfile, 4)) = "JPEG" _
Or UCase(Right(MY_Openfile, 3)) = "BMP" _
Or UCase(Right(MY_Openfile, 3)) = "WMF" _
Or UCase(Right(MY_Openfile, 3)) = "PCT" _
Or UCase(Right(MY_Openfile, 3)) = "GIF" _
Or UCase(Right(MY_Openfile, 3)) = "PNG" Then
i = i + 1
End If
MY_Openfile = Dir() '次のファイル名をキック
Loop
If i = 0 Then
MsgBox "このフォルダには写真がありませんでした。" & Chr(10) & Chr(10) & "写真のあるフォルダを再度指定して下さい。", 16, "写真一括貼り付けツール"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
End If
'配列の中にファイル名を入れる。
ReDim MY_Pictfile(i) '配列の宣言（i個のファイル数が分かったので、配列を再割り当て）
i = 0
MY_Openfile = Dir(CurDir() & "\*.*") 'ファイル名のみを「MY_Openfile」に格納
Do While MY_Openfile <> "" 'ファイルがあるまで繰り返す
If UCase(Right(MY_Openfile, 3)) = "JPG" _
Or UCase(Right(MY_Openfile, 4)) = "JPEG" _
Or UCase(Right(MY_Openfile, 3)) = "BMP" _
Or UCase(Right(MY_Openfile, 3)) = "WMF" _
Or UCase(Right(MY_Openfile, 3)) = "PCT" _
Or UCase(Right(MY_Openfile, 3)) = "GIF" _
Or UCase(Right(MY_Openfile, 3)) = "PNG" Then
i = i + 1
MY_Pictfile(i) = UCase(MY_Openfile)
End If
MY_Openfile = Dir()
Loop
'MY_Pictfile（配列）内をファイル名でソート（降順）･･･ バブルソート
c = i
For k = 1 To i - 1
For j = 1 To c - 1
a = MY_Pictfile(j)
b = MY_Pictfile(j + 1)
If a > b Then
MY_Pictfile(j + 1) = a
MY_Pictfile(j) = b
End If
Next j
c = c - 1
Next k
For k = 1 To i
MY_Openfile = MY_Pictfile(k)
If My_Flg = 1 Then
Rows("2:5").Copy
ActiveCell.Offset(-1, 0).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
My_Flg = 0
End If
My_Str = StrConv(LeftB(StrConv(Left(MY_Openfile, Len(MY_Openfile) - 4) & _
StrConv(Space(20), vbWide), vbFromUnicode), 50), vbUnicode)
ActiveCell.Offset(1, 0).Value = MidB(My_Str, 1, 26) & _
" " & Format(FileDateTime(MY_Openfile), "'yy/mm/dd(aaa) hh:mm ")
ActiveSheet.Pictures.Insert(CurDir() & "\" & MY_Openfile).Select
With Selection.ShapeRange
.LockAspectRatio = True
.Width = My_Width - 5
.Height = My_Height - 6
.Line.ForeColor.SchemeColor = 64
.Line.Visible = True
'.PictureFormat.IncrementBrightness 0.03 ’ブライトネス
'.PictureFormat.IncrementContrast 0.03 ’コントラスト
End With
Selection.Cut '画像サイズを小さくする為に、図 (JPEG)で貼り付けし直す。
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
Selection.ShapeRange.IncrementLeft 5
Selection.ShapeRange.IncrementTop 3
ActiveCell.ClearContents '「写真」の文字を消す
ActiveCell.Offset(0, 1).Select
If ActiveCell.Column >= 5 Then '行の変更がある場合
ActiveCell.Offset(4, -4).Select
My_Flg = 1
End If
Next k
ActiveSheet.Range("D1").Value = "写真貼付日：" & Format(Now, "'yy/mm/dd(aaa)") & " "
Application.CutCopyMode = False
My_cell = Selection.Cells.Address
j = 0
ActiveSheet.DrawingObjects.Select
For Each My_Picture In Selection
If TypeName(My_Picture) = "Picture" Then
j = j + 1
End If
Next
ActiveSheet.Range(My_cell).Select
Application.MoveAfterReturnDirection = xlToRight
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox " 写真を " & i & " 枚を貼り付けました。" & Chr(10) & Chr(10) & "（全部で " & j & " 枚の写真が貼り付いています。）" & Chr(10) & Chr(10) & _
" Ａ４サイズ（横）での印刷枚数は" & Chr(10) & Chr(10) & " " & Application.WorksheetFunction.RoundUp(j / 12, 0) & " 枚です。", 64, "写真一括貼り付けツール"
End Sub
Sub Photo_All_Clear()
Dim My_Picture As Variant
Dim My_Del_Ans As Integer
My_Del_Ans = MsgBox("★全ての写真と図形･コメントを含めて消去します。" & Chr(10) & Chr(10) & _
"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & Chr(10) & _
" はい ･･････ 写真と図形･コメントの全てを消去します" & Chr(10) & Chr(10) & _
" いいえ ････ 写真と図形を消去します (コメントは残す)" & Chr(10) & Chr(10) & _
" ｷｬﾝｾﾙ ･･･ 何もせずに戻ります。" & Chr(10) & Chr(10) & _
"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & Chr(10) & Chr(10) _
, 3 + 48 + 512, "全ての写真と図形･コメントの消去")
Select Case My_Del_Ans
Case 6 '6:はい
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Select
For Each My_Picture In Selection
If TypeName(My_Picture) <> "Button" Then
My_Picture.Delete
End If
Next
ActiveSheet.Range("A2:D65536").ClearContents
ActiveSheet.Rows("14:65536").Delete Shift:=xlUp
ActiveSheet.Range("A3,B3,C3,D3,A7,B7,C7,D7,A11,B11,C11,D11").Value = "写真"
Case 7 '7:いいえ
My_Del_Ans = MsgBox("再度質問します。" & Chr(10) & Chr(10) & _
"写真と図形を選択して消去する事が出来ます (コメントは残す)" & Chr(10) & Chr(10) & _
"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & Chr(10) & _
" はい ･･････ 写真と図形の両方を消去します(コメントのみ残す)" & Chr(10) & Chr(10) & _
" いいえ ････ 写真のみを消去します（図形とコメントは残す)" & Chr(10) & Chr(10) & _
" ｷｬﾝｾﾙ ･･･ 何もせずに戻ります。" & Chr(10) & Chr(10) & _
"~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" & Chr(10) & Chr(10) _
, 3 + 48 + 0, "写真と図形の消去")
Select Case My_Del_Ans
Case 6 '6:はい
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Select
For Each My_Picture In Selection
If TypeName(My_Picture) <> "Button" Then
My_Picture.Delete
End If
Next
Case 7 '7:いいえ
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Select
For Each My_Picture In Selection
If TypeName(My_Picture) = "Picture" Then
My_Picture.Delete
End If
Next
Case Else
Exit Sub
End Select
Case Else 'キャンセル
Exit Sub
End Select
ActiveSheet.Range("D1").ClearContents
ActiveSheet.Range("A3").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub auto_close()
Application.MoveAfterReturnDirection = xlDown
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
メッセージ的には2つ目の画像貼り付けで発生しているのではないかと思いますが、使っている命令自体はExcel2010でも動くものです。
特定の画像ファイルだけ駄目、とかはありませんか？
（???） 2016/03/29(火) 12:01
全シートを選択後、新しいブックにシートコピー。標準モジュールのマクロは全選択後、新しいブックに手動貼り付け。
これを試してみてください。
（???） 2016/03/29(火) 13:49
To もじゃ夫 さん
http://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=174877&rev=0
外部サイトに誘導するのは、よろしくないのですが、 上記URL先サイトにて、エクセルシートの指定した複数セルに、複数画像を貼り付けるマクロを 作成してますので参考にしてください。Pictures.Insert版とShapes.AddPicture版の２つがあります。
次の4つの記事が参考になると思います。 (2016/03/08(01:15)) (2016/03/08(11:29)) (2016/03/13(17:56)) (2016/03/13(23:01))
切り取り・貼り付けし直すことで、画像の解像度を落とす処理までしたかったのですが、 めんどくさくなって、やってません【(2016/03/14(01:17))の最後の記事参照】。
（マリオ） 2016/03/29(火) 16:42
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.