[[20111219151803]]　『工事写真台帳作成（応用がききません :_; ）』（マリン）　ページの最後に飛ぶ

『工事写真台帳作成（応用がききません :_; ）』（マリン）

 過去ログを調べてみて、近いものはあったのですが、やりたい事に
 あと一歩だったので、質問させていただきます。
 どなたか教えていただけると助かります。
 よろしくお願いいたします^^

Sub 複数画像の挿入()

    Dim a, c, sr, sc, s, rr, pkfile, ar, ac, z, rc, ccc, ca0
On Error GoTo err
    Set a = Application.InputBox("画像を挿入するセルを選択してください" _
            & Chr(13) & Chr(10) & "複数選択可 (ShiftキーまたはCtrlキーで選択)" _
         , "複数画像の一括挿入（セル選択）", Selection.Address, , , , , 8)
    Application.ScreenUpdating = False
         a.Select
        sr = Selection.Row
        sc = Selection.Column
    rr = sr
pkfile = Application.GetOpenFilename _
    ("すべての図(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif), *.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif", 2, "挿入する図の選択（複数選択可）", , True)
If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
    For fi = 1 To UBound(pkfile)
       If pkfile(fi) = False Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End 'キャンセルの場合終わる
    Next fi
n = ActiveSheet.Pictures.Count
Application.DisplayAlerts = False
z = MsgBox("画像のサイズをセルに合わせますか", vbYesNo, "複数画像の挿入")
ok = 0
If Application.Version < 12 Then
    If MsgBox("縦横比を保持しますか", 4, "複数画像の一括挿入") = 6 Then ok = 0 Else ok = 1
End If
If z = 6 Then ya = MsgBox("画像圧縮しますか", vbYesNo, "複数画像の挿入")
  ar = a.Address
 ac = Range(ar).Count
fi = 1
  If ac > 1 Then GoTo ech Else GoTo pc
ech:
    ca0 = ""
   For Each cc In ActiveSheet.Range(ar)
    ca = Range(cc.Address).MergeArea.Address
    rc = Range(ca).Rows.Count
    ccc = Range(ca).Columns.Count
    If rc > 1 Or cc > 1 Then
    ca = Cells(Range(ca).Row + rc - 1, Range(ca).Column + ccc - 1).Address
    End If
    If ca0 = ca Then GoTo mne
    ca0 = ca
    ca = Range(cc.Address).MergeArea.Address
    Range(ca).Select

' cc.Select

        g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
        fl = pkfile(fi)
'右のセルにファイル名を表示
        Cells(Range(ca).Row, Range(ca).Column + 1) = fl

        If z = 6 Then セルにサイズを合わせる
        fi = fi + 1
    If fi = UBound(pkfile) + 1 Then GoTo en
mne:
    Next
    Application.DisplayAlerts = True
    a.Select
Exit Sub

pc:

    For fi = 1 To UBound(pkfile)
        ca = Cells(rr, sc).Address
        Range(ca).Select
        g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
        fl = pkfile(fi)
'右のセルにファイル名を表示
        Cells(Range(ca).Row, Range(ca).Column + 1) = fl

        If z = 6 Then セルにサイズを合わせる
        rr = rr + 1
    Next fi
Exit Sub
en:
Application.DisplayAlerts = True
    Application.ScreenUpdating = False

    a.Select
Exit Sub
err: MsgBox "選択が正しくありません", , "複数画像の一括挿入"

End Sub

Sub セルにサイズを合わせる()

    Dim c As Range, cm As Range
    Dim rX As Single, rY As Single, r As Single

    Application.ScreenUpdating = False
'    For Each c In Selection

' Set cm = c.MergeArea

        Set cm = Range(ca)
'        If c.Address = cm.Item(1).Address Then
 '           If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
         ActiveSheet.Shapes(g).Select
           With Selection
                rX = cm.Width / .Width
                rY = cm.Height / .Height
                If ok = 0 Then
                    If rX < rY Then
                         cx = .Width * rX
                         cy = .Height * rX
                    Else
                         cx = .Width * rY
                         cy = .Height * rY
                    End If
                Else
                 cx = cm.Width
                 cy = cm.Height
                 End If
                    .Width = cx
                    .Height = cy
                    .Left = cm.Left
                    .Top = cm.Top + cm.Height - .Height
               If ya = 6 Then 図の圧縮
            End With
 '       End If
 '  Next
    Set cm = Nothing
    Application.ScreenUpdating = True
End Sub
Sub 図の圧縮()
    Selection.Cut
    Range(ca).Select
    ActiveSheet.PasteSpecial Format:="図 (JPEG)"
            ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=fl
        g = Selection.ShapeRange.Name

End Sub

 やりたい事①写真を張り付けるセルを指定したいです（例：B2､B14､B26､B37 等99枚です）
 やりたい事②上記のマクロを実行すると出来た写真全てにハイパーリンクが付いたままなので削除したいです。
 やりたい事③ファイル名は表示したくないです。

 自分なりに調べて、シート上にある全ての写真・画像のマクロを削除するマクロを見つけましたので↓にのせますが、これをどう組み込んでいいのかもわかりません。。。

Sub myHyperDelIMG()
'画像のハイパーリンクの削除

    Dim i As Long
    'Hyperlink applies to a Shape object
    Const msoHyperlinkShape As Long = 1

    For i = ActiveSheet.Hyperlinks.Count To 1 Step -1
        With ActiveSheet.Hyperlinks(i)
            If .Type = msoHyperlinkShape Then
                '画像のハイパーリンクを削除
                .Delete
            End If
        End With
    Next i
End Sub

 よろしくお願いいたします<(_ _)>

 う～ん・・・どうも、質問の意図がわからない。

 >やりたい事①写真を張り付けるセルを指定したいです（例：B2､B14､B26､B37 等99枚です）

 今、既にコードとしては、複数セルの選択を可能にしているけど？
 それはそれとして、たとえばセルを５つ選択し、写真は２つしか選択しなかったとしたら、どうなるのかな？

 >やりたい事②上記のマクロを実行すると出来た写真全てにハイパーリンクが付いたままなので削除したいです。

 ハーパーリンクがついている？

 >やりたい事③ファイル名は表示したくないです。

 それは、ファイル名をセルに記入してるからでしょ？
 アップされたコードに、「'右のセルにファイル名を表示」というコメントがあるね。

 追記）アップされたコードについて
　　・どれぐらい理解している？
　　・実行するエクセルバージョンを聞いて、処理を分岐させているけど、それは（マリン）さんの要件？
　　・圧縮の有無や縦横比なんかを指定させているけど、それも（マリン）さんの要件？

 (ぶらっと)

[[20100617110410]]

 近い仕様で作成したことがあったのですが、参考になりますか？
 （リンク投稿の下の方のユーザーフォームを使ったコード）

 又、投稿されたコードは、ご自身が作成されたものですか？
 Goto文を一切使わずに書き直してみては？
 勉強にはなりますよ！！

 ichinose

コメント返信：

[ 一覧(最新更新順) ]

[[20111219151803]] 『工事写真台帳作成（応用がききません :_; ）』（マリン） ページの最後に飛ぶ

[[20111219151803]]　『工事写真台帳作成（応用がききません :_; ）』（マリン）　ページの最後に飛ぶ