ウォーターサーバーとコーヒーマシンが一体化した画期的マシン >>

Excel2007のVBAからShell関数で外部実行プログラムを起動します。
外部実行プログラムは画像データをクリップボードへデータを出力後、自動で終了します。
Shell関数とWin32APIを使用して外部プログラムを実行し、プログラムが終了するまで待つように処理して、
クリップボードから指定する複数の結合したセルへ画像を貼り付ける事は出来たのですが、
画像がセルの左上を基準に貼り付けられます。
この画像を、セルの中央に位置調整したいのですが可能なのでしょうか?
また画像の回転(1度単位)は可能でしょうか?

'指定セルへクリップボードの内容を貼り付け
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("H53")

画像ファイルなどを読み込む訳ではないため、画像データ自体に名前がありません。
手動で位置調整は可能ですが、自動化出来ないかと色々調べ試してみたのですが、思う様に実現できません。
セルの結合は5行、列は結合していません。

どなたか御存知でしたら回答下さい。

このQ&Aに関連する最新のQ&A

A 回答 (6件)

またまた登場,onlyromです。



百聞は一見に如かず、ということで新しいブックのSheet1で以下を実行してください。


 H53~H57 を結合して(画像より大分大きめに幅、高さを広げておく)

任意の場所に画像を貼り付け、又は 挿入

その後、下記コードをコピペして実行


'---------------------------------------
Sub test()
 With Selection
  .Top = (Range("H58").Top - Range("H53").Top - .Height) / 2 + Range("H53").Top
  .Left = (Range("I53").Left - Range("H53").Left - .Width) / 2 + Range("H53").Left
 End With
End Sub
'----------------------------------------

どうですか?
ど真ん中に移動したと思いますが。
 

この回答への補足

>当方は動作確認してから投稿するようにしています。
決して意地悪をしている訳ではありませんので御容赦下さい。
時間を割いて回答頂いています事に感謝しています。

で、新しいブックで実行してみました。
確かにセルの中央に移動しました。
最初はエラーになるので、なぜなのか考えてみたら、
オブジェクトを選択状態にしないと駄目なんですね。

再度、質問になりますが、コード中の
Range("H53").Top - .Height
Range("H53").Left - .Width
「.Height」と「.Width」は挿入したオブジェクトの「高さ」、「幅」でしょうか?

やはり、VBAは難しい(><

補足日時:2008/03/06 13:43
    • good
    • 0

ANo.1


です。

>説明不足でしたがシートには、画像以外のものもあります。
(コマンドボタンなど)
何があっても関係ありません。

>確かに回転は不可能でした。
どんな画像か知りませんが、普通は回転できます。選択マークが黒四角になっていないでしょうね。

>移動は出来ましたが、微調整が微妙ですね。
私は、移動できることを示しただけで、細かいことは他の人の回答で十分です。onlyromさんでいいでしょう。

>セルのサイズを変更すると問題になりそうです。
セルサイズの変更とは関係ないようにもできます。
図の書式設定―プロパティ

>挿入する順番は決まっていませんので、Indexで指定出来るかどうか・
なぜ指定できないのですか。indexがわかれば指定できるでしょう。indexをとっておけばいいですよ。
また、名前を知ることができますし、気に入った名前につけ変えることもできます。

...Shapes(sn).name="適当な名前"
    • good
    • 0
この回答へのお礼

>なぜ指定できないのですか
「できない」はプログラムで実現できないではなく、VBA自体を理解できていないのでコードが書けないという意味です。
VB(NET以前)なら基本的な部分は理解出来るのですが、似た環境といっても、やはり違います。
エクセル自体使う機会が少ないですし。

コード自体は、もう少しのところで完成かな?というところまで進展しました。
名前のつけ変えもトライしてみたいと思います。

ありがとうございました。

お礼日時:2008/03/08 00:37

こんにちは。



Sub try()
  Const n As Long = 4  'margin
  Dim r  As Range
  Dim x  As Double

  With Worksheets("Sheet1")
    Set r = .Range("H53").MergeArea
    .Activate
    .PasteSpecial Format:="図 (拡張メタファイル)"
  End With
  With Selection.ShapeRange
    x = Application.Min((r.Width - n) / .Width, (r.Height - n) / .Height)
    .LockAspectRatio = msoTrue
    If x < 1 Then .Width = .Width * x
    .Left = r.Left + (r.Width - .Width) / 2
    .Top = r.Top + (r.Height - .Height) / 2
  End With
  ActiveCell.Select
  Set r = Nothing
End Sub

こんな感じでどうでしょう。

>確かに回転は不可能でした。
との記述から、Paste後、その画像はObjectとして貼り付けられていませんか?
選択して[名前BOX]で確認してみてください。
回転させるなら、Shapeとして貼り付けるのが手っ取り早いです。
その場合は [Rotationプロパティ]や[IncrementRotationメソッド]が使えます。

Selectionを使いたくなければokormazdさんが書かれている
...Shapes(Sheet.Shapes.Count) で指定できますよ。
コマンドボタンなどの画像以外のものがあっても判定できます。
Shapes.Count、つまりShapesの最大値のIndexでShapeを指定しますから
最後に追加されたShapeになります。

#PasteSpecialの場合、たぶんSheet.Activateが必要なのでSelectionで充分だとは思いますが。
    • good
    • 0
この回答へのお礼

end-uさん、ありがとうございます。
>最後に追加されたShapeになります。
確かにそうなりました。

質問には書いていなかったのですが、画像は複数挿入します。
ただ、挿入する順番は決まっていませんので、Indexで指定出来るかどうか・・・

提示頂いたコードは帰宅後試してみます。

お礼日時:2008/03/06 13:54

再度の登場、onlyromです。



>移動は出来ましたが、意図する位置に移動しませんでした。

当方は動作確認してから投稿するようにしています。
提示したコードも動作確認済です。
ちゃんとど真ん中に移動するはずです。

条件、■H53~H57の5セルが結合してありますか?

意図した動作をしないという質問者のコードをアップしてください。
一緒に解決しませう。
 
    • good
    • 0

●位置について●



セルのTop,Leftプロパティと
画像のTop,Left,Height,Widthプロパティから位置を計算する。

■H53~H57の5セルが結合してある場合

ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("H53")

に続けて以下のコードを。。

With Selection
 .Top = (Range("H58").Top - Range("H53").Top - .Height) / 2 + Range("H53").Top
 .Left = (Range("I53").Left - Range("H53").Left - .Width) / 2 + Range("H53").Left
End With

'----------------------------------------------------


●回転について●

図形(オートシェイプ)やグラフならIncrementRotationメソッドで回転できますが
貼り付けた(あるいは挿入した)画像(jpg,gif等)を回転させるメソッドはありませんので出来ません。

ただその貼り付けた画像はオートシェイプと同じく、Shapesコレクションに組み込まれますのでShapeオブジェクトで参照できます。

ということで回転はAPIになるでしょうからそれについてはネット検索してみてください。

以上。
    • good
    • 0
この回答へのお礼

onlyromさん、確かに回転は不可能でした。
移動は出来ましたが、意図する位置に移動しませんでした。
どちらかといえば右方向に移動したいのですが、左へ移動します。
コードと「にらめっこ」で色々調べてみたのですが・・・
再度方法を思案中です。

VBなら基本的なところは理解できているのですが、
VBAは「似て非なる」ものですね。

ありがとうございました。

お礼日時:2008/03/05 23:07

ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("H53")


sn = ActiveSheet.Shapes.Count
With ActiveSheet.Shapes(sn)
.Top = 200 '画像の行 1上端からの距離(pixel)
.Left = 200 '画像の列1左端からの距離(pixel)
.Rotation = 5 '回転角
End With

でどうでしょう。
    • good
    • 0
この回答へのお礼

okormazdさん、説明不足でしたがシートには、画像以外のものもあります。
(コマンドボタンなど)

コードをそのまま利用させて頂いたのですが、
確かに回転は不可能でした。
移動は出来ましたが、微調整が微妙ですね。
セルのサイズを変更すると問題になりそうです。
再度方法を思案中です。

ありがとうございました。

お礼日時:2008/03/05 22:59

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QエクセルVBAで画像を貼り付ける座標設定方法は?

Sheets("Sheet1")に貼り付けたJ-pegの画像(=シンボルマーク)を別なシートに貼り付けるのは下記のVBAで出来ました。ただ、これでは貼り付け先のシートのセルK12が、貼り付け元のK12と同じ位置でないと思った場所に張り付きません。
そこでセルで場所を指定するのではなく、座標のようなもので指定する方法はないものかと考えた次第です。
オートシェイプなどは座標指定で作成できるのですが、J-pegのような画像はどうすればいいのでしょうか?

Sub TEST()
Sheets("FACE").Shapes("シンボルマーク").Copy
ActiveSheet.Range("K12").Select
ActiveSheet.Paste
End Sub

Aベストアンサー

#1です。
>この場合、ファイルをエクセルにくっつけて渡すなんてこと
>はできないものでしょうか?(別々にではなくあくまでエク
>セルのブックに付属した形で)
Excelのブックに付属した形にするなら、コピーペーストする方がいいと思います。一旦挿入した画像を別途保存するのは、簡単には出来ないと思います。

複数のシートで同じような作業をするなら、次のような方法も考えられます。
Function CpyMrk(MrkNM As String, myTop As Single, myLeft As Single)
Sheets("FACE").Shapes(MrkNM).Copy
ActiveSheet.Paste
ActiveSheet.Shapes(MrkNM).Top = myTop
ActiveSheet.Shapes(MrkNM).Left = myLeft
End Function

Sub test()
CpyMrk "シンボルマーク", 10, 10
End Sub

QExcelで挿入した図をセルの中央に配置したいのです。

Excel2000を利用しているのですけども先日保護したシートに図を挿入する方法をこちらで教えて頂きました。ありがとうございます。
今回は、その挿入した図をセルの中央に配置する方法をご教授お願したいのですが、よろしくお願いいたします。セルの書式設定で中央にしてもできませんでした。セルを保護しているからでしょうか?それとも全く検討違いの操作をしているのでしょうか。
下記マクロにその操作を追加する場合のマクロも教えて頂ければ大変助かります。

ActiveSheet.Unprotect
Application.Dialogs(xlDialogInsertPicture).Show
ActiveSheet.Protect
以上宜しく御願い致します。

Aベストアンサー

どこで、どのようなエラーが出たのでしょうか?

1.("Picture 1")と("A1")の部分は利用しているExcelの状態に合わせて変更する必要があります。
Set shp図 = ActiveSheet.Shapes("Picture 1")でエラーの場合。
Picture 1の名称が違っている可能性が高いです。
マクロの記録で対象の図を移動してみてください。
マクロに図の名称が記録されますので、それを利用する必要があります。

2."位置移動のエラー"
図の大きさよりA1セルの大きさが小さいです。
入りきらないのでエラーです。A1セルを大きくするか、別のセルに変更してください。

3.いきなりエラーとなる。
Option Explicitを指定していませんか?

QExcelで挿入した図をセルの中央に配置したいです

よろしくお願いします
以前の質問を見ましたが
接合したセルの中央に配置したいので参考になりませんでした
EXCEL2000を利用しています
OSはXPです
16行4列を接合(左上がA26)しています
その位置に写真ファイルを挿入するのですが
中央に配置することができません
100シート近く挿入するので
簡単に出来ると助かります
よろしくお願いします

Aベストアンサー

マクロのサンプルを2つ書きました
picCenterは処理対象のセルを固定しています(この例ではアクティブなシートのA26セル)。
またselCenterは、シート上で選択されたセルを処理対象とします。(ただし選択されているのが結合セルでない場合は、先頭の1セルだけを処理対象範囲とします)

いずれも対象セル範囲にある画像を「対象セル範囲の中央」に配置します。ただし画像がセル範囲より大きいときは何もしません。

マクロはALT+F11でVBE画面を開き、左上のVBA Projectでシート名を右クリックし「挿入」→「標準モジュール」で表示される画面に貼り付けて下さい。マクロの実行はワークシート画面に戻ってALT+F8でマクロ一覧を開き、マクロ名を選択して「実行」ボタンです。

とりあえず「16行4列を接合(左上がA26)しています」の中に画像を貼り付けてマクロを動かしてみてください

Sub picCenter()
Dim p As Object
Dim rng, trg As Range
Const adr As String = "A26" '処理対象セルの左上のアドレス
  If Range(adr).MergeCells Then
    Set rng = Range(adr).MergeArea
  Else
    Set rng = Range(adr)
  End If
  For Each p In ActiveSheet.Pictures
    Set trg = Intersect(rng, p.TopLeftCell)
    If Not trg Is Nothing Then
      If p.Width < rng.Width Then
        p.Left = rng.Left + (rng.Width - p.Width) / 2
      End If
      If p.Height < rng.Height Then
        p.Top = rng.Top + (rng.Height - p.Height) / 2
      End If
    End If
  Next p
End Sub

Sub selCenter()
Dim p As Object
Dim rng, trg As Range
  If TypeName(Selection) = "Range" Then
    If Selection.MergeCells Then
      Set rng = Selection.Cells(1, 1).MergeArea
    Else
      Set rng = Selection.Cells(1, 1)
    End If
  End If
  For Each p In ActiveSheet.Pictures
    Set trg = Intersect(rng, p.TopLeftCell)
    If Not trg Is Nothing Then
      If p.Width < rng.Width Then
        p.Left = rng.Left + (rng.Width - p.Width) / 2
      End If
      If p.Height < rng.Height Then
        p.Top = rng.Top + (rng.Height - p.Height) / 2
      End If
    End If
  Next p
End Sub

マクロのサンプルを2つ書きました
picCenterは処理対象のセルを固定しています(この例ではアクティブなシートのA26セル)。
またselCenterは、シート上で選択されたセルを処理対象とします。(ただし選択されているのが結合セルでない場合は、先頭の1セルだけを処理対象範囲とします)

いずれも対象セル範囲にある画像を「対象セル範囲の中央」に配置します。ただし画像がセル範囲より大きいときは何もしません。

マクロはALT+F11でVBE画面を開き、左上のVBA Projectでシート名を右クリックし「挿入」...続きを読む

QVBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)

エクセル貼り付けた画像をセルにあった大きさにしたいのですが、
その際、縦と横の比率を変更したくありません。

縦と横の比率を変更せず、セルにおさまる最大の大きさで画像のサイズを
変えることは可能でしょうか。

-----------------------------------------------------------------------------
縦と横の比率が関係なく、セルいっぱいのサイズに画像の大きさを変更するVBAは
下記URLから見つけられたのですが、、、、、
http://q.hatena.ne.jp/1240648036

Aベストアンサー

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRng.Top
.Left = myRng.Left
.Height = myHgt
If .Width > myWdt Then
.Width = myWdt
End If
End With
Next mySp
End Sub

こんな感じではどうでしょうか?m(_ _)m

No.1です。

>画像が置いてあるセル上で処理を行う

画像のどこを基準にするか?によってコードは変わってきますが、
画像の左上端のセルにその画像を縦・もしくは横いっぱいに配置するコードにしてみました。

Sub Sample2()
Dim mySp As Shape, myRng As Range
Dim myHgt As Double, myWdt As Double

For Each mySp In ActiveSheet.Shapes
With mySp
Set myRng = .TopLeftCell
myHgt = myRng.Height
myWdt = myRng.Width
.Top = myRn...続きを読む

Q任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるようにしようとすると、かなり難易度が高くお手上げ状態です。
このプログラムをどのように改修すれば可能になるかお教えください。

Sub 図11()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可)", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("B6").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
ActiveCell.Offset(5).Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True

End Sub

よろしくおねがいします。
※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるよう...続きを読む

Aベストアンサー

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトしてください。また、DoEvents も入れておきました。
④は、何も手を付けていません。
コメント・アウトした部分で不要なら削除してください。

'//
Sub 図11R()
 'No. 9024507
 Dim strFilter As String
 Dim Filenames() As Variant
 Dim fName As Variant, ext As String
 Dim PIC As Picture
 Dim k As Long, m As Long
 Dim i As Long, j As Long
 Dim cnt As Long
 Dim FirstRng As Range
 Dim r As Range
 Dim Sel_Folder As Object, Sel_Path As String
 cnt = 0 'カウントの初期値
 '貼り付け最初のセル
 Set FirstRng = Range("A2")
 
  Set Sel_Folder = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "フォルダを選択してください", 5)

  If Not Sel_Folder Is Nothing Then
    Sel_Path = Sel_Folder.Self.Path
  Else
   Exit Sub
  End If
 
 ' 「ファイルを開く」ダイアログでファイル名を取得
 ChDir Sel_Path
' strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
' Filenames = Application.GetOpenFilename( _
' FileFilter:=strFilter, _
' Title:="図の挿入(複数選択可)", _
' MultiSelect:=True)
 fName = Dir("*.*", vbNormal)
 Do While fName <> ""
  If fName <> "." And fName <> ".." Then
   ext = Mid(fName, InStrRev(fName, ".") + 1)
   If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
    cnt = cnt + 1
    DoEvents
    ReDim Preserve Filenames(1 To cnt)
    Filenames(cnt) = fName
    ''安全のため(上限を設定)
    If cnt > 100 Then Exit Do
   End If
  End If
  fName = Dir()
 Loop
 If cnt = 0 Then Exit Sub
 
 ' ファイル名をソート
 Call BubbleSort_Str(Filenames, True, vbTextCompare)
 
 '' 貼り付け開始セルを選択
 'Range("B6").Select
 
 ' マクロ実行中の画面描写を停止
 Application.ScreenUpdating = False
 ' 順番に画像を挿入
 k = LBound(Filenames)
 m = UBound(Filenames)
 
 For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
  For i = 1 To 4
   Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
   Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
   
   '-------------------------------------------------------------
   ' 画像の各種プロパティ変更
   '-------------------------------------------------------------
   With PIC
    .Top = r.Top ' 位置:アクティブセルの上側に重ねる
    .Left = r.Left ' 位置:アクティブセルの左側に重ねる
    .Placement = xlMove ' 移動するがサイズ変更しない
    .PrintObject = True ' 印刷する
   End With
   With PIC.ShapeRange
    .LockAspectRatio = msoTrue ' 縦横比維持
    ' 画像の高さをアクティブセルにあわせる
    ' 結合セルの場合でも対応
    .Height = r.MergeArea.Height
   End With
   
   ' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
   ' ActiveCell.Offset(5).Select
   
   Set PIC = Nothing
   k = k + 1
   If k >= m Then Exit For
  Next i
 Next j
 Application.ScreenUpdating = True
 ChDir ThisWorkbook.Path
End Sub

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトし...続きを読む

QExcelのVBAで画像読込→サイズ変更がしたい。

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画像の名前が重複するのが原因だというところまではわかるのですが対処方法がわかりません。アドバイスをお願いします。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

gyo = ActiveCell.Row '画像読込位置の取得
Set scel = Cells(gyo, 3)

scel.Select 'セルサイズの取得
w = Selection.Width
h = Selection.Height

fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい") '画像読込
If fname = False Then
Exit Sub
End If
ActiveSheet.Pictures.Insert(fname).Select
i% = Selection.Index


Selection.Name = "gazou" & i '画像に名前をつける
Set 画像 = ActiveSheet.Shapes("gazou" & i)


With 画像 '画像のサイズ変更
.LockAspectRatio = False
.Placement = xlFreeFloating
.Placement = xlMove
.Width = w
.Height = h
End With

Range("F" & gyo).Select '摘要欄へ移動

End Sub

Excel2003を利用して仕事の工事写真帳を作成していますがVBAでどうしても上手くいかない部分があるので教えていただければと思い投稿しました。
【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ(写真サイズに結合してあります)を取得して画像サイズを変更して格納します。
【問題点】2枚以上画像を読み込んだ状態で実行すると目的の画像のサイズが変更にならない場合があります。
画像を削除したことで画...続きを読む

Aベストアンサー

画像にわざわざ名前をつける必要はあるのでしょうか?
(以下は一部抜粋して、少しだけ手を入れました)

Dim pict As String
 ActiveSheet.Pictures.Insert(fname).Select
 pict = Selection.Name
 With ActiveSheet.Shapes(pict) '画像のサイズ変更
  .LockAspectRatio = False
  .Placement = xlFreeFloating
  .Placement = xlMove
  .Width = w
  .Height = h
 End With

これなら画像を繰り返し削除しても大丈夫に思います

Qエクセルに画像を貼付け縮小する作業をマクロにしたいのですが、

エクセルに画像を貼付け縮小する作業をマクロにしたいのですが、
分からない部分があって困ってます。

(1)挿入したいセルにカーソルを合わせる
(2)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width = 480#
Selection.ShapeRange.Rotation = 0#
End Sub

これだと、写真が指定されてしまいます。
マクロの途中で止まって任意の写真を都度選べるようにできますか?
膨大な量の写真をセルに並べていきたいのです。

エクセルに画像を貼付け縮小する作業をマクロにしたいのですが、
分からない部分があって困ってます。

(1)挿入したいセルにカーソルを合わせる
(2)マクロ
 挿入-図-ファイル-図の挿入-図の書式設定-サイズ-30%

この作業を覚えさせると以下になりました。

Sub Macro3()
ActiveSheet.Pictures.Insert("C:\Documents and Settings\デスクトップ\1.JPG") _
.Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 360#
Selection.ShapeRange.Width =...続きを読む

Aベストアンサー

私も画像の取り込みでマクロをいじった経験があります。
こういうのはどうでしょう?(今動作確認できないのですが…)

Sub test()
ActiveSheet.Pictures.Insert(Application.GetOpenFilename).Select
Selection.Height = Selection.Height * 0.3
Selection.Width = Selection.Width * 0.3
End Sub

QVBAマクロで、図形等のオブジェクトを選択(特定)する方法ってありますか

こんにちは。VBAマクロを少しかじっています。
顔写真付きの従業員の検索システムを作りました。名前を入力(選択)したら、データシートから職員コード、住所、電話番号などの情報を検索し検索画面に表示します。この際、別のシートに顔写真を貼り付けたもの(1セルに1枚。セルに従業員名を入力してある。)から、VLOOKUP関数を使ってセル照会することで、画像も同時に表示することができます。
別の職員に切り換えたり、クリアする場合の画像の処理は、削除用のシートを用意し、そこにセルごと移動し、終了時にシートごと削除する方法をとりました。(当然、確認用のダイアログボックスが表示されます。)
前置きが長くなりましたが、問題は、用済みの画像を選択するプロシージャがあれば、あえて削除用のシートを用意する必要はありません。セルの場合は、Rangeプロパティやcellsプロパティで特定できますが、画像などのオブジェクトをセル番地などを使って特定する方法ってあるのでしょうか。
因みに、画像の選択処理を、マクロ記録でプロシージャを作成したら、
ActiveSheet.Shapes("Picture 1").Select などとなります。
よろしくお願いします。

こんにちは。VBAマクロを少しかじっています。
顔写真付きの従業員の検索システムを作りました。名前を入力(選択)したら、データシートから職員コード、住所、電話番号などの情報を検索し検索画面に表示します。この際、別のシートに顔写真を貼り付けたもの(1セルに1枚。セルに従業員名を入力してある。)から、VLOOKUP関数を使ってセル照会することで、画像も同時に表示することができます。
別の職員に切り換えたり、クリアする場合の画像の処理は、削除用のシートを用意し、そこにセルごと移動し、終了時...続きを読む

Aベストアンサー

検索シートにシェイプが1つしかなければ
ActiveSheet.Shapes(1).Select
で選択
ActiveSheet.Shapes(1).Delete
で削除できます。

QEXCEL VBA で現在開いているブックのファイル名を取得する方法

EXCEL2003 VBAで業務を簡素化するために、現在開いているブックのファイル名を取得する方法が分かりません。
作業手順をマクロを使って処理していますが、オリジナルのワークブックをファイル名を変えて保存し、以後、このワークブックを読み込んで使用しています。
このときのVBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり、以後の業務に使用できません。
常にファイル名を取得出来るVBAをどなたか、教えて下さい。

Aベストアンサー

>現在開いているブックのファイル名
 ちょっと曖昧な表現かなぁという気もいたしますが、VBAが書いてあるブックのブック名は
ThisWorkbook.Name
で、現在 "アクティブにして" 操作対象になっているブックの名前は
ActiveWorkbook.Name
ですね。

 しかし、
>VBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり
というような文脈からすると、
ThisWorkbook.Name
の方ですかね。

Q複数の画像ファイルを挿入したい

工事の仕事をしています。
報告書をエクセルで書いて出すのですが、
現場の写真を大量に撮影して貼り付けなければなりません。

「挿入」→「ファイルから」で一枚一枚貼り付けているのですが手間でなりません。

デジカメで撮影した写真なのでファイル名は連番です。
一括でワークシートにズラッと並べて挿入することはできないのでしょうか?

週末1-200枚の写真を貼る為に残業するのは堪えます。
良い知恵をお貸し下さい。

Aベストアンサー

工事写真票の作成ですか?報告書の提出時期ですものね。(^^;)

工事写真ということで、次の点が重要になるかと思います。

1. 貼付けられる順番
  工事の様子を時間を追って撮影している場合、順番が重要です。
2. リサイズの問題
  工事写真は正確性が求められます。リサイズする場合、縦横比を固定すべきです。

1と2をクリアしつつ、貼付けを楽にするには、EXCELではマクロしか解決方法がありません。個人的にはVIXをお勧めしますが、一応EXCELでのマクロをアップします。貼付け後のサイズはセルの高さにあわせています。必要があれば、コードをカスタマイズして下さい。

ただ、他の方からもご指摘があるとおり、EXCELに200枚の画像は無茶ですね。複数のブックに切り分けましょう。

なお、マクロ[InsertPictures]は#2.papayukaさんのコードをかなり拝借しておりますし、配列のソートプログラムも以前どこかで教えて頂いたものです。クイックソートの方が早いのですが、長くなるので、バブルソートで済ませています。


以下コード。

Option Explicit
Sub InsertPictures()
  
  Dim fName As Variant
  Dim i As Long
  Dim Pict As Picture

  fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
  If IsArray(fName) Then
    Application.ScreenUpdating = False
    '配列に格納されたファイル名をソート
    BubbleSort fName, True
    For i = 1 To UBound(fName)
      Set Pict = ActiveSheet.Pictures.Insert(fName(i))
      With Pict
        .TopLeftCell = ActiveCell
        .ShapeRange.LockAspectRatio = msoTrue
        'どちらかをコメントアウト
        .ShapeRange.Height = ActiveCell.Height 'セルの高さリサイズ
        '.ShapeRange.Width = ActiveCell.Width 'セルの幅にリサイズ
        ActiveCell.Offset(0, 1) = fName(i) 'ファイル名書込み
      End With
      ActiveCell.Offset(2, 0).Activate
      Application.StatusBar = "処理中:" & i & "/" & UBound(fName) & "枚目"
    Next i
  End If
  With Application
    .StatusBar = False
    .ScreenUpdating = True
  End With
  Set Pict = Nothing
  MsgBox i & "枚の画像を挿入しました", vbInformation

End Sub

'値の入替え
Public Sub Swap(ByRef Dat1 As Variant, ByRef Dat2 As Variant)

  Dim varBuf As Variant
  varBuf = Dat1
  Dat1 = Dat2
  Dat2 = varBuf

End Sub

'配列のバブルソート
Public Sub BubbleSort(ByRef aryDat As Variant, _
  Optional ByVal SortAsc As Boolean = True)

  Dim i As Long
  Dim j As Long
  For i = LBound(aryDat) To UBound(aryDat) - 1
    For j = LBound(aryDat) To LBound(aryDat) + UBound(aryDat) - i - 1
      If aryDat(IIf(SortAsc, j, j + 1)) > aryDat(IIf(SortAsc, j + 1, j)) Then
        Call Swap(aryDat(j), aryDat(j + 1))
      End If
    Next j
  Next i

End Sub

工事写真票の作成ですか?報告書の提出時期ですものね。(^^;)

工事写真ということで、次の点が重要になるかと思います。

1. 貼付けられる順番
  工事の様子を時間を追って撮影している場合、順番が重要です。
2. リサイズの問題
  工事写真は正確性が求められます。リサイズする場合、縦横比を固定すべきです。

1と2をクリアしつつ、貼付けを楽にするには、EXCELではマクロしか解決方法がありません。個人的にはVIXをお勧めしますが、一応EXCELでのマクロをアップします。貼付け後のサイズはセ...続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング