VBAの内容の修正をお願いしたく質問させて頂きます。
知人にExcel2007でシートのアルバムに写真をクリックで貼り付けられ、また別に張り付けてあるボタンでフォルダーを選択するとフォルダー内の写真を一括貼り付けるVBAを作成してもらいました。
ところがExcel2013で作成したものは他のPCで見られず、『リンク先が分からない・・・』と言った内容のメッセージが表示されます。
張り付けたボタンをクリックすると、フォルダーの選択はできますが、その後
『実行時”1004” PicturesクラスのInsertプロパティを取得できません』と言うメッセージが出ます。
残念ながら知人もよくわかりません。
表示内容がお分かりの方はぜひとも修正のご指導をお願いします。
写真のアルバムはA4サイズに横2×縦4の8枚を並べています。セルの結合が8枚あり、その場所をクリックすることで1枚1枚貼り付けることができます。
また、VBAでフォルダ内で番号順に並んでいる写真がばらばらに貼りついて今します。その部分も分かりましたら、よろしくお願いします。
VBA 左上表示:(General) 右上表示:画像貼り付け
Sub 画像貼り付け()
'===============フォルダ選択
Set myPath = CreateObject("Shell.Application") _
.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, 0)
If myPath Is Nothing Then Exit Sub
If myPath.Items Is Nothing Then Exit Sub
If myPath.Items.Item Is Nothing Then Exit Sub
フォルダ = myPath.Items.Item.Path
Set myPath = Nothing
'===============画像の掃除
' For Each mySP In ActiveSheet.Shapes
' myAD1 = mySP.TopLeftCell.MergeArea.Address
' myAD2 = Target.Address
' If myAD1 = myAD2 Then mySP.Delete
' Next
元シト = ActiveSheet.Name
セル = Array("C4", "AO4", "C21", "AO21", "C38", "AO38", "C55", "AO55")
i = 8
Set myFS = CreateObject("Scripting.FileSystemObject")
For Each myF In myFS.GetFolder(フォルダ).Files
myEXT = LCase(myFS.GetExtensionName(myF))
If myEXT = "jpeg" _
Or myEXT = "jpg" _
Or myEXT = "gif" _
Or myEXT = "tiff" _
Or myEXT = "bmp" _
Or myEXT = "png" _
Or myEXT = "tif" Then
If i > 7 Then
i = 0
Sheets(元シト).Copy after:=Sheets(Sheets.Count)
End If
'===============画像の貼り付け
Set mySP = ActiveSheet.Pictures.Insert(myF)
myMA = Range(セル(i)).MergeArea.Address
'===============タテヨコの縮尺を保持
myHH = Range(myMA).Height / mySP.Height
myWW = Range(myMA).Width / mySP.Width
If myHH > myWW Then
mySP.Height = Range(myMA).Height
mySP.Width = Range(myMA).Width
Else
mySP.Height = Range(myMA).Height
mySP.Width = Range(myMA).Width
End If
'===============中央へ調整
myHH2 = (Range(myMA).Height / 2) - (mySP.Height / 2)
myWW2 = (Range(myMA).Width / 2) - (mySP.Width / 2)
mySP.Top = Range(myMA).Top + myHH2
mySP.Left = Range(myMA).Left + myWW2
Set mySP = Nothing
i = i + 1
End If
Next
Set myFS = Nothing
End Sub
No.3ベストアンサー
- 回答日時:
答えを回答するとすれば、こんな感じかな~。
以下の2ヶ所を変更しています。
「'▼修正箇所(1)▼ ~ '▲▲▲▲▲▲▲」
「'▼修正箇所(2)▼ ~ '▲▲▲▲▲▲▲」
(変更前のコードはコメントアウトしています)
(1)箇所目はNo1で記述したAddPictureを利用する方法に変更
(2)箇所目は質問コードの縦横比率の保持処理が変だったので修正
あと質問のエラーについてはmyFがVariantだからです。
ファイルパスをCstrで文字列へ変換すればエラー回避できるかと。
(修正(1)に含みます)
【追記】
エクセルのVBAは型宣言を省略しても動作しますが、
宣言しないで使用すると変数の型が混雑しますので
やはり宣言はしたほうがよいかと。(今回はしていませんが)
No2の方がおっしゃっていますが、先頭にTAB入れてても
OKWebに張り付けると先頭の空白行は無視されるんですよね(;_;
(よって今回コードも詰まっていますが、ご愛嬌。)
■以下修正後のコードです入替えてください
Sub 画像貼り付け()
'===============フォルダ選択
Set myPath = CreateObject("Shell.Application") _
.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, 0)
If myPath Is Nothing Then Exit Sub
If myPath.Items Is Nothing Then Exit Sub
If myPath.Items.Item Is Nothing Then Exit Sub
フォルダ = myPath.Items.Item.Path
Set myPath = Nothing
'===============画像の掃除
' For Each mySP In ActiveSheet.Shapes
' myAD1 = mySP.TopLeftCell.MergeArea.Address
' myAD2 = Target.Address
' If myAD1 = myAD2 Then mySP.Delete
' Next
元シト = ActiveSheet.Name
セル = Array("C4", "AO4", "C21", "AO21", "C38", "AO38", "C55", "AO55")
i = 8
Set myFS = CreateObject("Scripting.FileSystemObject")
For Each myF In myFS.GetFolder(フォルダ).Files
myEXT = LCase(myFS.GetExtensionName(myF))
If myEXT = "jpeg" _
Or myEXT = "jpg" _
Or myEXT = "gif" _
Or myEXT = "tiff" _
Or myEXT = "bmp" _
Or myEXT = "png" _
Or myEXT = "tif" Then
If i > 7 Then
i = 0
Sheets(元シト).Copy after:=Sheets(Sheets.Count)
End If
'===============画像の貼り付け
'▼修正箇所(1)▼
Set mySP = ActiveSheet.Shapes.AddPicture(CStr(myF), False, True, 0, 0, 0, 0)
mySP.ScaleHeight 1, msoTrue
mySP.ScaleWidth 1, msoTrue
'Set mySP = ActiveSheet.Pictures.Insert(myF)
'▲▲▲▲▲▲▲
myMA = Range(セル(i)).MergeArea.Address
'===============タテヨコの縮尺を保持
'▼修正箇所(2)▼
myHSP = mySP.Height / mySP.Width
myHMA = Range(myMA).Height / Range(myMA).Width
If myHMA >= 1 Then
mySP.Width = Range(myMA).Width
If myHSP < myHMA Then
mySP.Height = mySP.Width * myHSP
Else
mySP.Height = mySP.Width * myHMA
End If
Else
myHSP = mySP.Width / mySP.Height
myHMA = Range(myMA).Width / Range(myMA).Height
mySP.Height = Range(myMA).Height
If myHSP < myHMA Then
mySP.Width = mySP.Height * myHSP
Else
mySP.Width = mySP.Height * myHMA
End If
End If
'myHH = Range(myMA).Height / mySP.Height
'myWW = Range(myMA).Width / mySP.Width
'If myHH > myWW Then
' mySP.Height = Range(myMA).Height
' mySP.Width = Range(myMA).Width
'Else
' mySP.Height = Range(myMA).Height
' mySP.Width = Range(myMA).Width
'End If
'▲▲▲▲▲▲▲
'===============中央へ調整
myHH2 = (Range(myMA).Height / 2) - (mySP.Height / 2)
myWW2 = (Range(myMA).Width / 2) - (mySP.Width / 2)
mySP.Top = Range(myMA).Top + myHH2
mySP.Left = Range(myMA).Left + myWW2
Set mySP = Nothing
i = i + 1
End If
Next
Set myFS = Nothing
End Sub
本当に!本当に!感謝!感謝!ありがとうございます!m(_ _)m
本来であれば自分で勉強をして、理解して作業をしなければいけないこと思いますが・・・できません。^^;
知人も過去にどこかのサイトから引っ張ってきて作った様で理解もしていません。--;
そうは言っても仕事で非常に重宝しており困っていました。
本当に『教えて!』の目的そのもののご回答をいただきました。
他力本願で非常によくないことは感じていますが・・・・^^;
兎にも角にも本当にありがとうございました!m(_ _)m
失礼承知で、また質問させて頂く事もあるかと思います。よろしくお願いいたします。^^/
No.2
- 回答日時:
同じ質問?
当方、Excel2003のため
とりあえず、1行1行ステップイン[F8」で確認。
データが全てちゃんと入っているか、下のウィンドウで確認して下さい。
myFにしっかりした値が入っていないということが考えられそうです。
Tabで分けてもらわないと、プログラムが見難いです。
1. しっかり変数定義がされていない。
全部全部そうですが、どこに定義されてるんです?
Dim ●● As String とか。
2013は変数定義は必要ないということで?
2. If のあと、 End IF で閉じられてない。
If myPath Is Nothing Then Exit Sub の後とかもそうですが
どこにEnd if があるんですか?
これで、エラーが出ないというのもおかしな話。
No.1
- 回答日時:
エクセルのバージョンで2010から「Pictures.Insert」を用いて画像を挿入した場合
リンク貼り付けになるように仕様がかわりました。
http://support.microsoft.com/kb/2396509/ja
http://detail.chiebukuro.yahoo.co.jp/qa/question …
AddPicture(LinkToFileをFalseにする必要事)を用いて画像を挿入してください。
詳しくは参考URLをご覧ください。
参考URL:http://www.moug.net/tech/exvba/0120020.html
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Visual Basic(VBA) このVBAでExcelアプリケーションを作成は必要ですか? 3 2023/07/19 21:13
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) 形式を選択して貼り付け 以下のコードで「元」シートと「先」シートのA列に同じ値があったら指定範囲をコ 5 2022/11/11 07:30
- Excel(エクセル) Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて 2 2022/11/15 16:14
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Visual Basic(VBA) InputBoxでキャンセルボタンを押したらファイル自体を閉じたい 3 2022/07/23 17:52
- PowerPoint(パワーポイント) ExcelのVBAコードについて教えてください。 3 2022/05/25 14:32
- Visual Basic(VBA) Excel vbaについての質問 3 2023/04/18 16:14
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 2 2022/05/26 17:19
このQ&Aを見た人はこんなQ&Aも見ています
-
プロが教えるわが家の防犯対策術!
ホームセキュリティのプロが、家庭の防犯対策を真剣に考える 2組のご夫婦へ実際の防犯対策術をご紹介!どうすれば家と家族を守れるのかを教えます!
-
Pictures.Insertメソッド⇒Shapes.AddPictureメソッドに変更したいです。
Visual Basic(VBA)
-
エクセルのマクロで特定フォルダ内のJPGファイルを検索して開きたいので
Excel(エクセル)
-
マクロで画像挿入→エラー「リンクされたイメージを表
Excel(エクセル)
-
-
4
画像を削除したい(VBA)
Word(ワード)
-
5
VBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)
Excel(エクセル)
-
6
エクセルに張り付けた写真のファイル名が見たい
Microsoft ASP
-
7
エクセル マクロ 相対パスから画像を読み込みたいです。
その他(Microsoft Office)
-
8
VBAで保存しないで閉じると空のBookが残る
Excel(エクセル)
-
9
セルサイズに自動で合わせて画像を貼るマクロとカレンダーマクロでエラー表示・変数宣言とは。
Excel(エクセル)
-
10
VBAで選択した画像を貼り付けたい
Excel(エクセル)
-
11
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
-
12
エクセルのエラーメッセージ「400」って?
Visual Basic(VBA)
-
13
Excelのパスが格納されている列の隣の列に画像を自動で表示させたい
その他(Microsoft Office)
-
14
VBAで画像印刷
Visual Basic(VBA)
-
15
エクセルで複数のシートに画像のはりつけ
その他(Microsoft Office)
-
16
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
17
UserForm1.Showでエラーになります。
工学
-
18
エクセルVBA 個人用マクロブックのSubをcall出来ない
Excel(エクセル)
-
19
エクセルのセルに指定画像(.jpg)を自動で貼り付けたいです。
Excel(エクセル)
-
20
Excel セルに入力した画像名からフォルダの画像を自動表示させたい
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
同級生の顔を使ってエロ画像を...
-
至急回答お願いします、彼氏に...
-
JPEGファイルに文字を入れたい
-
iPhoneで写真を撮りました。 端...
-
pixivの画像を保存しようとした...
-
可愛い子はプリクラが盛れない...
-
マクロで画像挿入→エラー「リン...
-
「強調」の対義語は何ですか?
-
Word差し込み印刷 画像更新され...
-
証明用写真の作り方をお教えく...
-
可愛い子がプリクラを撮ると盛...
-
PCでPDFファイルを電子書籍のよ...
-
L版サイズの紙に複数の画像を印...
-
PCで、写真を保存しようとした...
-
アマゾンドライブフォトにある...
-
「湾岸の千葉君」での秀里毅の写真
-
受信した添付写真を大きくする
-
EXIF情報がない場合はどのよう...
-
持っている写真の画質を上げる...
-
スクショした画像をLINEのトプ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
同級生の顔を使ってエロ画像を...
-
iPhoneで写真を撮りました。 端...
-
至急回答お願いします、彼氏に...
-
JPEGファイルに文字を入れたい
-
マクロで画像挿入→エラー「リン...
-
可愛い子はプリクラが盛れない...
-
pixivの画像を保存しようとした...
-
「強調」の対義語は何ですか?
-
tiffファイルの解像度変更の仕方
-
受信した添付写真を大きくする
-
至急です!!答えてくださいお願...
-
撮影日時をそのままに残して画...
-
持っている写真の画質を上げる...
-
PCでPDFファイルを電子書籍のよ...
-
証明用写真の作り方をお教えく...
-
「湾岸の千葉君」での秀里毅の写真
-
整形外科などで、MRIやレントゲ...
-
写真の下に文字を入れるには?
-
エクセル・ワードの表を画像化...
-
VBAの内容の修正をお願いさせて...
おすすめ情報