[[20181207212356]]　『画像とファイル名を取込と編集後の移行』（狭山）　ページの最後に飛ぶ

『画像とファイル名を取込と編集後の移行』（狭山）

お世話になります。
以下の作業が可能でしたらマクロのコードを教えていただけないでしょうか

デスクトップにフォルダー『画像処理（前）』と『画像処理（後）』
があり.jpg画像は『画像処理（前）』の中に数百枚あります。
他に『画像編集』という名前のエクセルブックがあり
その中のシート名は『変更』があります。
行いたい事ですが
『変更』シートでマクロを実行し『画像処理（前）』の画像を
シートに取り込む
画像の大きさは（高さ８センチ横６センチ）で全ての画像を挿入縦一列に取込
画像の横のG列に取り込んだ画像の名前を書き出す。（画像の横に）
画像を編集してH列に変更したい画像名を入れて　
画像を『画像処理（後）』に.jpgで移行する。
その中で移行しないNG（写真撮影失敗）のものもありますので
H列が空白の場合その画像は移行をしない。

このような感じなのですが、どうぞ宜しくお願いいたします。

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

 確認すると、

 デスクトップにフォルダー『画像処理（前）』と『画像処理（後）』 があり
 『画像処理（前）』の中に jpg画像が数百枚あります。 
 他に『画像編集』という名前のエクセルブックがあり、
 その中に『変更』シートがあります。

 行いたい事は次のとおりです。
 1.『画像処理（前）』の画像を『変更』シートに取り込む 
 2. 画像の大きさは（高さ８センチ横６センチ）で全ての画像を挿入、縦一列(F列?)に取込む
 3. 画像の横のG列に、取り込んだ画像の名前を書き出す。（画像の横に）
 4. 画像を編集してH列に変更したい画像名を入れて、
 5. 画像を『画像処理（後）』に.jpgで移行する。 
 6. その中で移行しないNG（写真撮影失敗）のものもありますので 
    H列が空白の場合その画像は移行をしません。

 4．は手作業、それ以外をマクロにしたい、ということでしょうか。

 前半部分は、「画像をシートに挿入するマクロ」などと検索してみてください。
 いろいろ記事があります。
 例えば、
 https://www.moug.net/tech/exvba/0120020.html

 後半は、chartオブジェクトを使う方法が簡便でしょうか。
 最近の質問であれば、別掲示板ですが、
 「シート画像保存」
 http://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=187978&rev=0
 を参考にしてみて下さい。

 ご自分でトライしたうえで、不明な点を質問した方がよいと思います。
（γ） 2018/12/08(土) 09:54

（γ）様

 早速にありがとうございました。
 説明が下手で申し訳ございません。

 2. 画像の大きさは（高さ８センチ横６センチ）で全ての画像を挿入、縦一列(F列?)に取込む
 縦一列(F列?)に取込むですが　画像の左脇がB列です。

　 4．は手作業、それ以外をマクロにしたい、ということでしょうか。

 はい。そのとおりです。

 一つ入っていない事がありましたので
 ・画像の横のG列に取り込んだ画像の名前を書き出す。（画像の横に）

 帰宅後に参考のURLを見させていただきます。

 （結構複雑になりそうで不安です）
（狭山） 2018/12/08(土) 11:17

試していませんが考え方だけ

前半部分は
１）高さ８センチ横６センチの空のchartオブジェクトを追加
２）画像を挿入

を繰り返すと、後半部分が簡単にできそうな気がします。

（マナ） 2018/12/08(土) 11:22

＞マクロのコードを教えていただけないでしょうか
いつものとおり、質問ではなくコード作成依頼だという理解でよいのですよね。
とりあえず、私は作成依頼をお受けするタイプではないので、依頼を受けていただける方が現れることをお祈りします。

以下、そのような回答者さんが現れずに自分で考えてみる場合のヒントというかアイデアです。

＞デスクトップにフォルダー『画像処理（前）』と『画像処理（後）』
＞があり.jpg画像は『画像処理（前）』の中に数百枚あります。
＞他に『画像編集』という名前のエクセルブックがあり
＞その中のシート名は『変更』があります。
＞行いたい事ですが
＞『変更』シートでマクロを実行し『画像処理（前）』の画像を
＞シートに取り込む

 これをやるには、フォルダに入っている画像ファイルを検索して、
 ひとまずリストアップする必要がありますよね。
 それは↓がそのまま使えるのではないでしょうか？
[[20181107234449]]　『JPGの画像の名前変更』（狭山）

＞画像の大きさは（高さ８センチ横６センチ）で全ての画像を挿入縦一列に取込

 Excelは通常、幅や高さをメートル法で管理してないので結構難しいとおもいます。
 ただ、アドインの導入に抵抗がなければ、セルの幅高さをセンチ単位で調整することが
 出来るようになるものが公開されているので導入されるとよいでしょう。

＞画像の横のG列に取り込んだ画像の名前を書き出す。（画像の横に）
＞画像を編集してH列に変更したい画像名を入れて　

 こちらは、どのように編集するか不明ですが、G列に名前を書きだしているので、
 ハイパーリンクを設定しておいてクリックしたら画像編集ソフトが起動するように
 しておくと便利だとおもいます。

＞画像を『画像処理（後）』に.jpgで移行する。

 こちらは、よくわかりません。
 画像を"編集"したあとにjpgで保存するだけでは？

以上、アイデアだけですが提供します。

（もこな２） 2018/12/08(土) 18:02

１個の画像ファイル限定の動作確認用サンプルです。
実際には、
１）前半処理と後半処理は別のプロシージャにする
２）すべての画像について繰り返し処理する
について修正する必要があります。
当然ですが、１個用コードが理解できないと
先には進めないと思います。

 Option Explicit

 Sub test()
    Dim ws As Worksheet
    Dim cht As Chart
    Dim T As Single, L As Single, W As Single, H As Single
    Dim デスクトップ As String
    Dim 変更前 As String, 変更後 As String
    Dim 画像名 As String

    デスクトップ = CreateObject("WScript.Shell").SpecialFolders("Desktop")

    変更前 = デスクトップ & "\画像処理（前）\"
    変更後 = デスクトップ & "\画像処理（後）\"

    Set ws = ActiveSheet

    L = ws.Columns("B").Left
    T = 0
    W = 6 / 2.54 * 72
    H = 8 / 2.54 * 72

    画像名 = "エクセルの学校.jpg"

    Set cht = ws.ChartObjects.Add( _
            Left:=L, Top:=T, Width:=W, Height:=H).Chart
    cht.ChartArea.Border.LineStyle = xlLineStyleNone
    cht.Parent.ShapeRange(1).TopLeftCell.Offset(, 5).Value = 画像名

    cht.Shapes.AddPicture _
            Filename:=変更前 & 画像名, _
            LinkToFile:=False, SaveWithDocument:=True, _
            Left:=-1, Top:=-1, Width:=W, Height:=H

    画像名 = cht.Parent.ShapeRange(1).TopLeftCell.Offset(1, 5).Value
    If 画像名 <> "" Then
        cht.Export Filename:=変更後 & 画像名
    End If

 End Sub

（マナ） 2018/12/08(土) 19:02

（マナ）様（マナ）様
いつもありがとうございます。
（マナ）様のを入れてみまして以下の部分にエラーが出てしまいました
しかし　エクセルの学校.jpgと高さ８センチ横６センチは出てきました。

cht.Shapes.AddPicture _

            Filename:=変更前 & 画像名, _
            LinkToFile:=False, SaveWithDocument:=True, _
            Left:=-1, Top:=-1, Width:=W, Height:=H

大変申し訳ないのですが自宅のPCが１台しかなく家族が使用するため
明日の夜か月曜にテスト等を行うことになるかと思います。
ただ、使用していない合間で行いたいと思います。

（狭山） 2018/12/08(土) 19:32

「変更前」や「画像名」かの文字列が実際の文字列と全角、半角、大文字、小文字等まで全く同一になっていますか？
（とおりすがり） 2018/12/09(日) 10:56

＞しかし　エクセルの学校.jpgと高さ８センチ横６センチは出てきました。

↓ここは、実際にあるファイル名に変更して動作確認してください。

 ＞画像名 = "エクセルの学校.jpg"

エラーと関係ないですが、ここも修正してください。

 ＞cht.Parent.ShapeRange(1).TopLeftCell.Offset(, 5).Value = 画像名
　　↓
  cht.Parent.ShapeRange(1).TopLeftCell.Offset(1, 5).Value = 画像名
                                              ~~

（マナ） 2018/12/09(日) 18:50

(マナ）様
ありがとうございます。
コードの変更と実際のファイル名を入れて１つの画像と名前を書き出すことができました。

自分でも色々なサイトで以下のコードを見つけて
行ってみましたが

Sub 写真を挿入する()

Dim WS1 As Worksheet
Dim WS2 As Worksheet

Set WS1 = Worksheets("変更")

'一覧貼り付け用シートをコピーして使う
Worksheets("写真一覧用").Copy after:=WS1
ActiveSheet.Name = Format(Date, "YYMMDD") & Second(Now)
Set WS2 = ActiveSheet

Dim LCRN1 As Long
LCRN1 = WS1.Cells(3, 9).End(xlDown).Row

Dim PicName As String
Dim PicID As String
Dim N1 As Integer
Dim Zahyou As Long
Dim StrNum As Long

Cells(1, 2).Select
StrNum = 3
Zahyou = 96

'一つ一つの画像を貼り付けて移動させる

For N1 = 3 To LCRN1

    PicName = WS1.Cells(7, 2) & WS1.Cells(N1, 9)
    PicID = WS1.Cells(N1, 9)

    ActiveSheet.Pictures.Insert(PicName).Select

        With Selection

            .Top = Zahyou
            .Left = 50
            .Width = 364
            .Height = 226.6

        End With

    Cells(StrNum, 1) = PicID

    StrNum = StrNum + 16
    Zahyou = Zahyou + 384

End Sub

Sub 画像一覧取得()

Dim myFile As Variant

 'ファイルを開く形式で、フォルダーを指定する
myFile = Application.GetOpenFilename("jpgファイル(*.jpg),*.jpg")

Dim vFileName As String
Dim Num As Long

'取得したパス名を記録しておく
Cells(5, 2) = myFile

Dim PathLength As Integer
PathLength = Len(myFile)

Dim N1 As Long
N1 = 1

'ファイル名以外の部分を残すために最後の\の位置を確認する
Do

    Cells(6, 2) = Right(myFile, N1)
    N1 = N1 + 1

    If Left(Cells(6, 2), 1) = "\" Then

        Exit Do

    End If

Loop

Cells(7, 2) = Left(myFile, Len(myFile) + 1 - Len(Cells(6, 2)))

vFileName = Dir(Cells(7, 2))

Columns(9).Delete

Num = 3

'パスの中にあるファイル名をすべて書き出す
Do Until vFileName = ""

    Cells(Num, 7) = vFileName
    Num = Num + 1

    vFileName = Dir

Loop

End Sub

今回のこの件ですが大変申し訳ございませんが
自分では無理と分かりました。
日数もないため手作業にて行います。

皆様、大変申し訳ございませんがこの件は終了にして下さい。
また今後何かございましたら宜しくお願いいたします。
（狭山） 2018/12/09(日) 20:49

 Option Explicit

 Sub 取り込み()
    Dim cht As Chart
    Dim T As Single, L As Single, W As Single, H As Single
    Dim 変更前 As String
    Dim 画像名 As String

    変更前 = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\画像処理（前）\"

    L = Columns("B").Left
    T = 0
    W = 6 / 2.54 * 72
    H = 8 / 2.54 * 72

    画像名 = Dir(変更前 & "*.jpg")

    Do While 画像名 <> ""
        Set cht = ChartObjects.Add( _
                Left:=L, Top:=T, Width:=W, Height:=H).Chart
        cht.ChartArea.Border.LineStyle = xlLineStyleNone

        With cht.Parent.ShapeRange(1).TopLeftCell.Offset(1, 5)
            .Value = 画像名
            cht.HasTitle = True
            cht.ChartTitle.Formula = "=" & .Address(, , , True)
        End With

        cht.Shapes.AddPicture _
                Filename:=変更前 & 画像名, _
                LinkToFile:=False, SaveWithDocument:=True, _
                Left:=-1, Top:=-1, Width:=W, Height:=H

        T = T + H
        画像名 = Dir()
    Loop

 End Sub

 Sub 保存()
    Dim cho As ChartObject
    Dim 変更後 As String
    Dim 画像名 As String

    変更後 = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\画像処理（後）\"

    For Each cho In ChartObjects
        With Range(Mid(cho.Chart.ChartTitle.Formula, 2))
            画像名 = .Offset(, 1).Value
            If 画像名 Like "*.jpg" Then
                cho.Chart.Export Filename:=変更後 & 画像名
                cho.Delete
                .Resize(, 2).ClearContents
            End If
        End With
    Next

 End Sub

（マナ） 2018/12/11(火) 22:39

（マナ）様

 すみません。投稿いただけるとは思ってませんでした。
 あれから手作業にて300枚位の作業をしていました。
 やはりマクロ実行にて行なえれば効率がいいなどと思っていました。

 今、行ってみましたところ

 Set cht = ChartObjects.Add( _ 
 コンパイルエラー
 変数が定義されていませんと出まして
 の ChartObjectsの部分が黄色くなってしまいます。

 お返事をいただけたら嬉しいです。

（狭山） 2018/12/12(水) 14:41

シートオブジェクトを指定していないようなので、マクロはシートモジュールに貼ることを想定しているようですよ？マクロの編集画面を開いた場合には、このほうが楽ですし。

標準モジュール上で動かすなら、ActiveSheet.ChartObjects のように、各オブジェクトの前にシートオブジェクトを明記してみてください。
（???） 2018/12/12(水) 15:24

（???）様

 ご教授ありがとうございました。
 私のミスでした。
 シートモジュールに貼ってエラーは大丈夫でした。感動です。
 大変失礼いたしました。

 もう一つ私のミスを発見してしまいました。
 画像処理（後）に移行された画像のプロパティをみましたら
 大きさ：283×378
 幅：283ピクセル
 高さ：378ピクセル
 水平方向の解像度：120dpi
 垂直方向の解像度：120dpi
 と小さくなってしまいまして

 画像処理（前）に入っているのと同じ大きさで移行は難しいでしょうか
 大きさ：480×640
 幅：480ピクセル
 高さ：640ピクセル
 水平方向の解像度：96dpi
 垂直方向の解像度：96dpi
 当初、要望をお伝えするのを忘れていたのが・・
 反省しております。
 申し訳ございません。

（狭山） 2018/12/12(水) 18:52

確認のため、新しいブックで以下を動かしてみてください。

 Sub test()
    Dim OBJ As Object

    With CreateObject("WbemScripting.SWbemLocator")
        For Each OBJ In .ConnectServer.ExecQuery("Select * From Win32_DisplayConfiguration")
            MsgBox OBJ.LogPixels & " DPI", vbInformation, "画面解像度"
        Next OBJ
    End With
 End Sub

おそらく、これが120DPIになっているのかと思います。

この場合、マナさんの取り込みプロシジャの画像サイズ指定している箇所を、以下のように変えてみてください。

    W = 480! * 72 / 120
    H = 640! * 72 / 120

ただし、これでは120DPIの画面で見ると480x640になるだけで、96DPIにはなりません。（今見ている環境のDPIが記録されてしまうため）これを画面とは無関係に自由に指定するならば、現在のChartObjectsによる変換方法は止めて、GDI++というAPIを駆使した、とても難しいコーディングにする必要があるので、DPIについては諦めるのが良いと思いますよ。（手作業でもDPI変更は難しいですし、元の要望から外れすぎです）

（???） 2018/12/13(木) 10:55

なお、120DPIの画面に拘らなければ、96DPIの画面を用意する（文字サイズを標準にすれば96DPIかな？）事で、目的に適った出力ができるかと思いますよ。
（???） 2018/12/13(木) 11:09

（???）様

 お返事が遅くなり申し訳ございません。
 沢山のご教授ありがとうございます。
 早速にご指示のSub test()を行いましたら
 96DPI と出ました。
 また、
 W = 480! * 72 / 120
 H = 640! * 72 / 120に変更し実行しましたところ
 以下のようになりました。

 大きさ：480×640
 幅：480ピクセル
 高さ：640ピクセル
 水平方向の解像度：120dpi
 垂直方向の解像度：120dpi
 やはり
 水平方向の解像度と垂直方向の解像度は取り込む前の画像と同じにはならないのですね

 すみませんが画像の中にセルのデータを画像として貼り付けて（画像の左下です）
 グループ化にしたいのですが
 例としまして１枚だけ記録を取ってみました。
 全てを行うことは可能でしょうか

Sub 図として貼り付け()
'
' 図として貼り付け Macro
'

    Range("J2:J7").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Copy
    ActiveSheet.Pictures.Paste.Select
    ActiveSheet.Shapes.Range(Array("Picture 107")).Select
    Selection.ShapeRange.IncrementLeft -537.6
    Selection.ShapeRange.IncrementTop 120
    Selection.ShapeRange.ScaleHeight 0.8121546961, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth 0.8454545455, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth 1.1182795699, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.Height = 85.0393700787
    Range("F9").Select
    ActiveSheet.Shapes.Range(Array("Picture 107")).Select
    ActiveSheet.Shapes.Range(Array("Picture 107", "Chart 1")).Select
    ActiveSheet.Shapes.Range(Array("Picture 107", "Chart 1")).Select
    Selection.ShapeRange.Group.Select
    ActiveSheet.Paste
    ActiveSheet.Shapes.Range(Array("Picture 109")).Select
    Application.CutCopyMode = False
End Sub

 J2:J7を範囲を選択して塗りつぶし白を選択
 この範囲をコピーして図として貼り付け
 画像とこの図を選択してグループ化

 を記録しました。
 また画像にする選択範囲は全部書けませんが
 J2:J7
 J14:J19
 J27:J32
 J39:J44
 という範囲です。
 何度も申し訳ございませんがご教授お願いいたしいます。

（狭山） 2018/12/13(木) 20:15

 すみません。図の大きさですが
 高さ5.2
 幅3.6　です。何度も申し訳ございません。
（狭山） 2018/12/13(木) 20:22

DPI確認用マクロで96DPIと表示されたのならば、画面は本来96DPIだと思われます。WINDOWSの文字サイズ設定を、大きなフォントに変えていませんか？標準にしてみてください。（今より文字が小さくなって読みにくくなるでしょうけど、96DPIを取るか、文字サイズを取るかの2択です）

そして、グループ化は話が別ですし、具体的な部分を全部書いていないせいか、要件がいまいちよく判りません。また、マナさんがChartObjectsを使ったのは画像サイズ変換のためであり、変換後画像は普通に張り付ければシンプルにグループ化できますから、いろいろ試してみると良いでしょう。

    ActiveSheet.Shapes.Range(Array("Picture 107", "Picture 109")).Select 'こんな感じ
（???） 2018/12/14(金) 09:53

（???）様

 ご教授ありがとうございました。
 96DPIを優先したいと思います。

 グループ化は話が別ですし
 その通りでした。申し訳ございませんでした。

 少し試しながら行いたいと思います。

 最後に以下が行いたかった事です。

 画像は工事用の画像で画像の中に（左下）工事名等の情報を背景を白で文字を黒にて
 白板を貼り付ける貼り付けを行いたかったのです。

 J2:J7の６つのセルに他のシートから反映されている関数が入っています
 このJ2:J7を１つの図としてから画像の左下の角に合わせて貼り付けて
 画像とその図をグループ化ループ化にして移行をしたかったのです。
 ただ全てを貼り付けるわけではなく例えばＫ列のどこかに行こうかどうかの
 〇等を付け上記の作業を行いたいと思っていました。

 このような感じでした。
 本当にありがとうございました。

（狭山） 2018/12/14(金) 19:37

コメント返信：

[ 一覧(最新更新順) ]

[[20181207212356]] 『画像とファイル名を取込と編集後の移行』（狭山） ページの最後に飛ぶ

[[20181207212356]]　『画像とファイル名を取込と編集後の移行』（狭山）　ページの最後に飛ぶ