[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『工事写真台帳作成(応用がききません :_; )』(マリン)
過去ログを調べてみて、近いものはあったのですが、やりたい事に あと一歩だったので、質問させていただきます。 どなたか教えていただけると助かります。 よろしくお願いいたします^^
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枚です) やりたい事A上記のマクロを実行すると出来た写真全てにハイパーリンクが付いたままなので削除したいです。 やりたい事Bファイル名は表示したくないです。
自分なりに調べて、シート上にある全ての写真・画像のマクロを削除するマクロを見つけましたので↓にのせますが、これをどう組み込んでいいのかもわかりません。。。
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枚です)
今、既にコードとしては、複数セルの選択を可能にしているけど? それはそれとして、たとえばセルを5つ選択し、写真は2つしか選択しなかったとしたら、どうなるのかな?
>やりたい事A上記のマクロを実行すると出来た写真全てにハイパーリンクが付いたままなので削除したいです。
ハーパーリンクがついている?
>やりたい事Bファイル名は表示したくないです。
それは、ファイル名をセルに記入してるからでしょ? アップされたコードに、「'右のセルにファイル名を表示」というコメントがあるね。
追記)アップされたコードについて ・どれぐらい理解している? ・実行するエクセルバージョンを聞いて、処理を分岐させているけど、それは(マリン)さんの要件? ・圧縮の有無や縦横比なんかを指定させているけど、それも(マリン)さんの要件?
(ぶらっと)
近い仕様で作成したことがあったのですが、参考になりますか? (リンク投稿の下の方のユーザーフォームを使ったコード)
又、投稿されたコードは、ご自身が作成されたものですか? Goto文を一切使わずに書き直してみては? 勉強にはなりますよ!!
ichinose
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.