- ベストアンサー
Excel VBAで画像読込→サイズ変更
- Excel2003の仕事の工事写真帳作成でVBAで画像読込とサイズ変更が上手くいかない
- 2枚以上の画像を読み込むと目的の画像のサイズが変更されない問題が発生
- 画像削除による画像名の重複が原因で対処方法がわからないのでアドバイスを求める
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
関連するQ&A
- Excel2003で作成したマクロがExcel2007で上手く動かない。
以前、Excel2003を利用して工事写真帳を作成する方法を質問させていただきました。その後、工事写真帳は実用化して利用していますがWindows vistaのPCが増え、Excel2007でこの工事写真帳を使ってみたところ、次のような症状が起きてしまいます。どう訂正したら良いか教えていただければと思い再度投稿しました。 【仕様】工事写真帳は1シート構成、用紙1枚に3枚画像が入り、画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ（写真サイズに結合してあります）を取得して画像サイズを変更して格納します。 【問題点】ダブルクリックをすると読み込みたいセルより若干ずれた場所（左上寄り）に読み込まれます。2枚目以降ダブルクリックをすると1枚目の画像の上に重なった状態で読み込まれてしまいます。 コードは次の通りです。ぜひアドバイスをお願いします。 Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) Dim pict As String gyo = ActiveCell.Row 'クリック行の取得 retu = ActiveCell.Column 'クリック列の取得 If retu = 3 Then Set scel = Cells(gyo, retu) scel.Select 'セルサイズの取得 w = Selection.Width h = Selection.Height fname = Application.GetOpenFilename _ ("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい") '画像読込 If fname = False Then Exit Sub End If ActiveSheet.Pictures.Insert(fname).Select pict = Selection.Name With ActiveSheet.Shapes(pict) '画像のサイズ変更 .LockAspectRatio = False .Placement = xlFreeFloating .Placement = xlMove .Width = w .Height = h End With Range("F" & gyo).Select '摘要欄へ移動 End If End Sub
- ベストアンサー
- オフィス系ソフト
- Excel VBA による特定Recordの抽出
VBAの初心者です。 各コマンドの意味もよく理解してないため、原因が判りません・・・。 ■特定情報を抽出するVBAの結果が合致しません。 ・Record数が「5000件」あるExcelFileから、Field：3に「1」が入力されているRecordを抽出するVBAを作りました。 ・ExcelsheetでFilterにより抽出するとField：3には「1」が「839件」入力されています。 しかし、実際に作成したVBAを走らせてみると「800件」しか抽出できません。 ■下記が作成したVBAです。 -------------------------------------------- 1)Private Sub task_Select2() Range("F1").Select Selection.AutoFilter Field:=6, Criteria1:="=1", Operator:=xlAnd Rows("3:5503").Select Range("B3").Activate Selection.Delete Shift:=xlUp Selection.AutoFilter Field:=6 ActiveWindow.LargeScroll Down:=-13 Range("B1").Select End Sub 2)Private Sub backup_task2() 'バックアップ用コピー処理 Dim Model As String, fName As String Model = ActiveSheet.Name fName = Model & "_wo" Worksheets(Model).Copy After:=Worksheets(Model) ActiveSheet.Name = fName Worksheets(Model).Activate End Sub 3)Private Sub task_Select3() Selection.AutoFilter Field:=3, Criteria1:=">1", Operator:=xlAnd Rows("3:10000").Select Range("B3").Activate Selection.Delete Shift:=xlUp Selection.AutoFilter Field:=3 ActiveWindow.LargeScroll Down:=-25 Range("B1").Select End Sub 4)Sub A_Main_task() '動作用メイン処理 Application.Run "backup_task" Application.Run "task_Loop" Application.Run "CommentMix" End Sub 5)Private Sub backup_task() 'バックアップ用コピー処理 Dim model As String, fName As String Model = ActiveSheet.Name fName = Model & "_copy" Worksheets(Model).Copy After:=Worksheets(Model) ActiveSheet.Name = fName Worksheets(Model).Activate End Sub -------------------------------------------- 1）でField：6に情報が入力されてないRecordを削除。 3）でField：3に「1」以外が入力されているRecordを削除。 ●1）の「Rows("3:5503").Select」でRecord「5000件」なら問題ないと思いましたが、 1）の結果は「4770件」でした。（5000件になると思ったのですが・・・） ・5000件以上のRecordを処理させようと思い、「Rows("3:5503").Select」の範囲を単純に増やしても1）の結果が減ってしまいます。 ◎Record数が「2700件」程度の情報は問題なく目的数の情報を抽出できました。 ●来週18日の月曜日中になんとか作成したい資料なのです。 お手数ですが宜しくお願いします。
- 締切済み
- オフィス系ソフト
- エクセル2010のvbaについて
押されたコマンドボタンの名前を取得したいです （調べてみましたがエラーになり取得できませんでした） 後コマンドボタンがたくさんあり、コードも長く とても邪魔なので省略したいのですができますか？ （左クリックと右クリックで違う処理をした後 MouseDown コマンドボタンの名前で少し処理を変えるコードです） MouseUp （下のコードのような感じです） 回答お願いします Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Select Case Button Case 1 Range("A1") = 1 Case 2 Range("A1") = 2 End Select End Sub Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) If （コマンドボタンの名前を取得） = "aaa" Then Range("A1") = Range("A1") + 1 Else Range("A1") = Range("A1") - 1 End If End Sub
- 締切済み
- その他MS Office製品
- VBAで特定の文字が含まれている画像ファイル
下記コードで画像の貼り付けを行っていますが 現在は適当な順番で貼り付けが行われます。 Declare Function SetCurrentDirectory Lib "kernel32" Alias _ "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long Sub ShapeLoadtest() Dim Fname As Variant, fe As Variant Dim Fn As Variant, Pic As Shape Dim pno As Long Dim myFileName As String Dim strFileName As String Range("B4").Select SetCurrentDirectory "C:\Users\yuya\Desktop\画像\" Fname = Application.GetOpenFilename _ (",*", MultiSelect:=True) If Not IsArray(Fname) Then MsgBox "取り消されました。", vbInformation Exit Sub End If Application.ScreenUpdating = False pno = 0 For Each Fn In Fname 'この次へ追加すべき行 Selection.Offset(-1, 0) = Mid(Fn, InStrRev(Fn, "\") + 1, Len(Fn) - InStrRev(Fn, "\")) ActiveCell.Select Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=Fn, _ LinkToFile:=False, _ SaveWithDocument:=True, _ Left:=0, Top:=0, Width:=0, Height:=0) With Pic .ScaleWidth 1, msoTrue .ScaleHeight 1, msoTrue .Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる .Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる .Placement = xlMove ' 移動するがサイズ変更しない End With If ActiveCell.Column = 2 Then ActiveCell.Offset(, 8).Select ElseIf ActiveCell.Column = 10 Then ActiveCell.Offset(, 8).Select ElseIf ActiveCell.Column = 18 Then ActiveCell.Offset(32, -16).Select End If Set Pic = Nothing pno = pno + 1 Next Application.ScreenUpdating = True Range("A1").Select MsgBox pno & "枚の画像を挿入しました", vbInformation End Sub これを画像ファイル名に【あいう】という文字が混じっていたら If ActiveCell.Column = 2 Then ActiveCell.Offset(, 8).Select のセルに 【１２３】という数字が混じっていたら ElseIf ActiveCell.Column = 10 Then ActiveCell.Offset(, 8).Select のセルに貼り付けという具合にしたいです。 よろしくお願いします。
- ベストアンサー
- Excel（エクセル）
- VBAで画像を自動で切り替える方法
Ｅｘｃｅｌで棚割表を作っています。商品コードを打つとその商品の画像を自動で表示させたいのですが、雑誌を見ながらコードをアレンジしてほぼ完成したのですが、「プロシージャーが大きい」とエラーが出てマクロを実行出来ません。 画像は100個程度あり、先に別のマクロで貼り付けてあります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ファイル As String If Intersect(Target, Range("A4")) Is Nothing Then ActiveSheet.Shapes("画像").Delete ファイル = "C:\保存場所\" & Range("A4").Value & ".jpg" Range("B5").Select ActiveSheet.Pictures.Insert(ファイル).Select Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Top = ActiveCell.Top Selection.ShapeRange.Left = ActiveCell.Left Selection.ShapeRange.Height = 97 Selection.ShapeRange.Width = 52.5 Selection.ShapeRange.Rotation = 0# Selection.ShapeRange.IncrementLeft 1.5 Selection.ShapeRange.IncrementTop 1.5 Selection.Name = "画像" End If （中略） Dim ファイル98 As String If Intersect(Target, Range("U60")) Is Nothing Then Exit Sub ActiveSheet.Shapes("画像98").Delete ファイル98 = "C:\保存場所\" & Range("U60").Value & ".jpg" Range("V61").Select ActiveSheet.Pictures.Insert(ファイル98).Select Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Top = ActiveCell.Top Selection.ShapeRange.Left = ActiveCell.Left Selection.ShapeRange.Height = 97 Selection.ShapeRange.Width = 52.5 Selection.ShapeRange.Rotation = 0# Selection.ShapeRange.IncrementLeft 1.5 Selection.ShapeRange.IncrementTop 1.5 Selection.Name = "画像98" End Sub 省ける箇所や分割する方法などありましたら教えてください。
- ベストアンサー
- オフィス系ソフト
- EXCEL VBA これであっていますか？
エクセルに地図を貼り付け、その中のある地点Aから半径１キロ、２キロ、３キロといった具合に円を描いています。ある地点B、Cも同様に円があります。セルに“A” と入力した際に該当する地点の円（１キロ、２キロ、３キロの3種類）を赤く表示し、終了すると円が消える（線なしに変わる）ようにするために以下のようなＶＢＡを組みました。が、円が２つしか赤くならなかったり、 ばあいによっては「インデックスが境界を超えています」とエラーが出たりします。 どうしたら良いか教えてください。 Sub iro() Dim i As Variant i = InputBox("表示する地点を指定してください", "地点指定") If i = "A" Then ActiveSheet.Shapes(1).Select ActiveSheet.Shapes(2).Select ActiveSheet.Shapes(3).Select Replace:=False hyoji MsgBox "表示を終了してよろしいですか", vbOKOnly ActiveSheet.Shapes(1).Select ActiveSheet.Shapes(2).Select ActiveSheet.Shapes(3).Select Replace:=False modosu ElseIf i = "B" Then ActiveSheet.Shapes(4).Select ActiveSheet.Shapes(5).Select ActiveSheet.Shapes(6).Select Replace:=False hyoji MsgBox "表示を終了してよろしいですか", vbOKOnly ActiveSheet.Shapes(4).Select ActiveSheet.Shapes(5).Select ActiveSheet.Shapes(6).Select Replace:=False Else MsgBox "指定した地点がありません", vbOKOnly End If End Sub Sub hyoji() Selection.ShapeRange.Line.Visible = msoTrue '「線なし」に設定されている場合、線を表示 Selection.ShapeRange.Line.ForeColor.SchemeColor = 10 Range("A1").Select End Sub Sub modosu() Selection.ShapeRange.Line.Visible = msoFalse '「線なし」に設定 Range("A1").Select End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBA・画像を張り付けるコードについて
次のような目的で以下のコードを作成しました。 1.オリンパス社のカメディアマスターというソフトで複数の画像を表示 2.希望の画像を選択してコピー 3.B1に希望の画像を一定サイズで張り付ける sub 画像貼付 () Range("B1").Select ActiveSheet.Paste Selection ShapeRange.Height 200 Selection ShapeRange.Width 200 End Sub 今回、ご教授したいのは次のとおりです。 上記で2つ目以降の画像を別のシートに貼り付ける際、誤ってカメディアソフト上で画像を選択しないでマクロを実行すると、前回の画像が貼り付いてしまいます。 これを何らかの方法で防ぎたいのです。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- 挿入した画像を等倍ではなく、サイズを指定したい
Sub Macro1() ActiveSheet.Pictures.Insert( _ "C:\Users\画像.gif").Select With Selection.ShapeRange .ScaleWidth 1, msoFalse, msoScaleFromTopLeft .ScaleHeight 1, msoFalse, msoScaleFromTopLeft End With End Sub これで画像を挿入し、サイズを変更してるのですが １だと等倍になってしまうようです。 常に１ｃｍとか、サイズを指定して変更するプロパティはありますか？
- ベストアンサー
- オフィス系ソフト
- エクセル2007のマクロで画像挿入がうまくいきません。
エクセル2007のマクロで画像挿入がうまくいきません。 写真のサイズ縦横比がセルにあっていないので伸びてしまいます。 下記のプログラムでサイズ変更も可能でしょうか？ フォームのボタンの上に張り付けた場合、ボタンを隠す事は 出来ますか？ ボタンの色は変更できるのでしょうか？ いろいろわがままな質問で申し訳ありません。 マクロ初心者です。 Sub Pic_in2007() fname = Application.GetOpenFilename ActiveSheet.Pictures.Insert(fname).Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = range("B5:C6").height Selection.ShapeRange.Width = range("B5:C6").width Selection.ShapeRange.left = range("B5:C6").left Selection.ShapeRange.top = range("B5:C6").top End Sub
- ベストアンサー
- オフィス系ソフト
- Excel２００３で動いたVisualが２００７では？
Excel２００３で作った下記のVisual Basicが２００７では、最初にクリックしたところには行かず いつも同じ位置に挿入されます。 出来ればセルF1の位置に挿入したいのですが Sub macro1() Dim Fname As String Dim FLT As String Dim Sheetmei As String FLT = "JPEGファイル(*.jpg),*.jpg" Fname = Application.GetOpenFilename(FLT, 2, "開く", True) If Fname = "False" Then Exit Sub End If Sheetmei = Worksheets(1).Name ActiveSheet.Pictures.Insert(Fname).Select Call Jpeg_size_adjust End Sub サブで下記も有ります Sub Jpeg_size_adjust() Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = 270.75 Selection.ShapeRange.Width = 360
- 締切済み
- オフィス系ソフト
お礼
回答ありがとうございます。 早速直して実行してみたところ、上手くいきました。 本を1冊購入して一通り目を通しましたが、実務では ネットで同じような例題を探して利用している状況なので 不要なコードを使用していることが多々ありそうです。 これでやっと実用化ができます。ありがとうございました！