複数選択で一括で貼り付けることができるとっても便利なコードなのですがこれを変更したいです。
1、貼り付けた写真を結合セルの中央に持ってきたい。
2、複数選択し貼り付けるとき任意の順番で貼り付けたい。
(1段目左上、1段目右上、2段目左上、2段目右上…)
★3、写真タイトルを、取り込むファイル名(拡張子は除く)
↑これは、出来れば嬉しい
こんな機能付けるコードは、難しいでしょうか?
1,2,3を、解決することが出来たのでコード削除しました。
画像を、載せたかったのですがまた載せられない状態になっているので時間をおいて載せたいと思います。
気になる質問をクリップする
クリップした質問は、後からいつでもMYページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。

回答3件
0
sgr-2さんが非常に優しい方なので、
これ以上の回答は必要ないと思いますが、
こういった質問に疑問がありますので苦言させて頂きます。
仕事でコードを書いてる方にとっては
ご要望を実現することは簡単です。
しかし、知識・意欲が無い方には、
コードの意味が全く分からないと思いますので、
自分で仕様を変えてサンプルを作りなおすことは不可能です。
だから結果的にsgr-2さんはかなり具体的なコードを提示することになるでしょう。
あなたが作成も理解もしていないコードを掲示し、
要望を掲げて優しい方に奉仕させる、
ここはそういった場所ではないと思います。
投稿2015/11/23 07:45
総合スコア1175
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
0
ベストアンサー
こんにちは。
現状のコードの素性やいきさつは分からないので、思い切って作り直してしまう手段はあると考えています。
色々作り込んでしまっているなら、考えないといけない事がありそうですが、質問文中の条件1,2,3を満足すれば良いのであれば現状コードに沿う必要もないのかな。と思いました。
soft/index.htmの方を見ると、改変に関しては「改変は自己責任において自由」とされていました。
個人的には、改変ではなく作り直しへの方針転換(?)をお勧めします。
ちょっとメンテナンスが大変かな…と思ってしまいました。。
2の「任意の順番で貼り付けたい」を実現するなら、以下のようなフォームを作ってしまいたいですね。
どうしましょう?
まっさらから(作り直し)でも良ければ、私から情報を出す事ができそうですが
追記 2015/11/24
単純に目的の機能を満足するだろうサンプルを書いてみました。
以下コードの「SetImageMain関数」へ引数として
・1つ以上の配置先となるセル範囲(オペレーション的には多分Application.Selection)
・イメージファイルの一覧(フルパス文字列)
を渡してあげれば良いです。
VBA
1Option Explicit 2 3'<summary> 4' 指定されたセルへイメージを配置 5'</summary> 6'<param name="targetRng">処理対象全体の範囲</param> 7'<param name="imageFiles">イメージファイル(配列)</param> 8Sub SetImageMain(targetRng As Range, imageFiles() As String) 9 On Error Resume Next 10 Err.Clear 11 12 Dim FileSysObj As Object 'Scripting.FileSystemObject 13 Dim targetSht As Worksheet '対象のワークシート 14 Dim targetCell As Range '処理対象の範囲(セル) 15 Dim strMergeAreaOld As String '前回の処理範囲(結合セル)を記憶 16 Dim imgNameRng As Range 'イメージ名を設定するセル 17 Dim fileIdx As Integer 'ファイルのインデックス 18 Dim retVal As Boolean 'SetImage関数の戻り値受け取り用 19 20 'ファイル名から名前部分を取得するのに利用 21 Set FileSysObj = CreateObject("Scripting.FileSystemObject") 22 23 strMergeAreaOld = "" 24 fileIdx = LBound(imageFiles) 'ファイル一覧(配列)の最初の位置を取得 25 26 '対象のワークシートを取得 27 Set targetSht = targetRng.Parent 28 29 For Each targetCell In targetRng 30 31 With targetSht.Range(targetCell.Address) 32 33 '前回の範囲と一致する場合は次へ 34 If strMergeAreaOld = .MergeArea.Address Then 35 GoTo CONTINUE_FOR 36 End If 37 38 'イメージ配置の関数を呼び出し 39 retVal = SetImage(.MergeArea, imageFiles(fileIdx)) 40 41 '隣接するセルへファイル名の名前部分を記入 42 Set imgNameRng = targetSht.Cells(targetCell.Row + .MergeArea.Rows.Count, targetCell.Column) 43 imgNameRng = "'" + FileSysObj.GetBaseName(imageFiles(fileIdx)) 44 45 fileIdx = fileIdx + 1 '次のイメージへ 46 47 If fileIdx > UBound(imageFiles) Then 'イメージリストの終端に到達 48 Exit For 49 End If 50 51 strMergeAreaOld = .MergeArea.Address '今回の範囲を記憶 52 53 End With 54CONTINUE_FOR: 55 Next targetCell 56 57 Set FileSysObj = Nothing 58End Sub 59 60 61'<summary> 62' イメージを配置する 63'</summary> 64'<param name="mergeCell">配置対象のセル(結合)</param> 65'<param name="imageFile">イメージのファイル名</param> 66Function SetImage(ByRef mergeCell As Range, imageFile As String) As Boolean 67 On Error Resume Next 68 Err.Clear 69 70 Dim WSht As Worksheet 'イメージ配置の対称Worksheet 71 Dim Img As Shape '配置したイメージ 72 Dim rWidth As Double 'セルの幅とイメージ幅の比 73 Dim rHeight As Double 'セルの高さとイメージ高さの比 74 Dim ScaleVal As Double 'サイズ調整用のスケール値 75 76 SetImage = False 77 78 '対象のワークシートを取得 79 Set WSht = mergeCell.Parent 80 81 'イメージを配置 82 Set Img = WSht.Shapes.AddPicture(fileName:=imageFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=mergeCell.Left, Top:=mergeCell.Top, width:=0, height:=0) 83 84 Img.ScaleWidth 1, msoTrue '幅を元のサイズに 85 Img.ScaleHeight 1, msoTrue '高さを元のサイズに 86 Img.LockAspectRatio = msoTrue '縦横比を固定 87 88 89 rWidth = mergeCell.width / Img.width 90 rHeight = mergeCell.height / Img.height 91 92 If rWidth < rHeight Then 93 ScaleVal = rWidth 94 Else 95 ScaleVal = rHeight 96 End If 97 98 'ScaleValが1未満(セルに収まらない)場合に縮小 99 If ScaleVal < 1# Then 100 Img.width = Img.width * ScaleVal '縦横比固定なのでWidthかHeightいずれかを指定すれば良い 101 End If 102 103 '中央に配置 104 Img.Top = mergeCell.Top + (mergeCell.height - Img.height) / 2 105 Img.Left = mergeCell.Left + (mergeCell.width - Img.width) / 2 106 107 If Err.Number = 0 Then SetImage = True 'エラーがなければTrueを返す 108End Function
こちらのコードで機能的には大丈夫だろうと思います。
投稿2015/11/23 04:45
編集2015/11/23 21:55総合スコア294
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。

0
このコードって、
エクセルの学校
『工事写真台帳作成(応用がききません :_; )』(マリン)
http://www.excel.studio-kazu.jp/kw/20111219151803.html
の丸写しに見えますが?
もともとのサイトでは、コードの来歴が触れられていませんが、
それを置いておいても、
他人のコードを無断で、丸写し状態で掲示するのは、如何なモノでしょうか?
投稿2015/11/22 12:12
総合スコア2030
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。

あなたの回答
tips
太字
斜体
打ち消し線
見出し
引用テキストの挿入
コードの挿入
リンクの挿入
リストの挿入
番号リストの挿入
表の挿入
水平線の挿入
プレビュー
質問の解決につながる回答をしましょう。 サンプルコードなど、より具体的な説明があると質問者の理解の助けになります。 また、読む側のことを考えた、分かりやすい文章を心がけましょう。