| |
初めに長文にて失礼いたします
Ａ１に入っている写真を一旦削除（無ければスルー）してから、写真を選択し縮小してから張り付ける。なお写真はリンクにならないようする。
というようなマクロを作りたいのですがどうしたらよいのでしょうか？
以前、色々なＨＰなどを見てエクセル2003で作成したのですが、写真を選択し縮小してから張り付けるまではできたのですが、エクセル2010にしたところ、同じフォルダにないと写真が「リンク...」と表示されるようになってしまいました。
さらに違うＰＣでマクロを動かすと、写真のサイズが微妙に変わってしまうのです。
せっかくなので、
1.Ａ１に写真があれば、一旦削除
2.リンク表示をなくす
の機能を追加して新たに作成ということで今回も様々なＨＰなどを検索してみたのですが、うまくできませんでした。
（以前のマクロ）
Sub Acespic1()
Dim FName As String
Dim myPct As Object
FName = Application.GetOpenFilename(FileFilter:="JPG形式(*.jpg),*.jpg", Title:="ファイルを選択してください")
If FName = "False" Then Exit Sub
Range("A1").Select
Set myPct = ActiveSheet.Pictures.Insert(FName)
With myPct.ShapeRange
.LockAspectRatio = msoTrue
.Height = 255
.IncrementTop 3.75
End With
End Sub
（とあるＨＰから見つけたマクロ）
複数選択でき、リンク表示もされないため、すごく良かったのですが、削除のマクロを追加したいのと、縮小した写真がぼやけてしまいます。一旦保存して再度開くくと綺麗な写真になるのですが…
丸々の流用なのでとあるＨＰの回答者様に失礼かもしれませんが、下記の通りです
'図をリンク オブジェクトではなく図として挿入する
'Pictures.Insert メソッドではなく、Shapes.Add メソッドを使用
Sub 複数の画像を挿入01()
Dim strFilter As String
Dim Filenames As Variant
Dim objShape As Shape
Dim i As Integer
' 「ファイルを開く」ダイアログでファイル名を取得
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("A2").Select
' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filenames(i), False, True, Selection.Left, Selection.Top, 50#, 50#)
'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With objShape
.ScaleHeight 1!, msoTrue
.ScaleWidth 7!, msoTrue
.Height = ActiveCell.MergeArea.Height
.Placement = xlMove ' 移動するがサイズ変更しない
End With
' 次の貼り付け先を選択（アクティブセルにする）[例：2個下のセル]
ActiveCell.Offset(2).Select
Set objShape = Nothing
Next i
' 終了
Application.ScreenUpdating = True
MsgBox UBound(Filenames) & "枚の画像を挿入しました", vbInformation
End Sub
' バブルソート（文字列） 'ORIGINAL
Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)
If Not IsArray(Source) Then Exit Sub
Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
If StrComp(Source(IIf(SortAsc, j, j + 1)), _
Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
vntTmp = Source(j)
Source(j) = Source(j + 1)
Source(j + 1) = vntTmp
End If
Next j
Next i
End Sub
|
|
acs
- 16/7/27(水) 11:43 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
≪
