• 締切済み

PNG画像の大きさ取得(エクセルvba)

PNG画像の幅と縦の取得ができなくて困っています。 PNG以外でしたら、下記の関数に画像ファイルのパスを渡せば求められるのですが、 LoadPicture関数がPNG未対応のようです。 Sub subGetPicSize(PicPath As String) Dim P Set P = LoadPicture(PicPath) MsgBox CLng(P.Width * 0.0378) & "×" & CLng(P.Height *　0.0378) End Sub 画像変換ツールでPNGをBMPなどほかの形式にすれば、大きさを求められますが、よりよい方法を知っていれば教えてください。 宜しくお願いします。

みんなの回答

回答No.1

http://www.vector.co.jp/soft/win95/prog/se206517.html

sadoria
質問者

お礼

ご回答ありがとうございます。 リンク先ファイルから試したものの、動作させられませんでした。 プログラミングについてあまり詳しくないので、この機会にCOMオブジェクトの使い方を学ぼうと思います。 （作業環境はWindowsXP,Office2000で試しました）

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • フォルダーに入った画像名の取得したい

    ＶＢ初心者です。色々調べて、セルに「画像名と画像サイズ一覧」を 書き出すことができました。 しかし、書き出せたのはjpgだけで、gifやpngをフォルダー内に入れると エラーが・・・・ どうしたらgifやpngも書き出せるコードになるか教えてください。 よろしくお願いします。 書いたコードは下記です。 Sub GetImageSize(ByVal f, ByRef x, ByRef y) Dim p Set p = LoadPicture(f) x = CLng(CDbl(p.Width) * 24 / 635) y = CLng(CDbl(p.Height) * 24 / 635) Set p = Nothing End Sub Sub main() Dim FSO As New FileSystemObject Dim FLD As Folder Dim FLE As File Dim FF As File Dim x As Long Dim y As Long Set FLD = FSO.GetFolder("C:\画像の入ったフォルダー名") For Each FF In FLD.Files Call GetImageSize(FF, x, y) Name = FF.Name Name_x = x Name_y = y myCnt = myCnt + 1 Cells(myCnt, "A").Value = FF.Name Cells(myCnt, "B").Value = x Cells(myCnt, "C").Value = y Next FF End Sub

  • エクセル2010のvbaについて

    Sub abc() Dim a Set a = Selection If a.Width * 4 / 3 <> 90 And a.Height * 4 / 3 - 1 <> 120 Then MsgBox ("120x90px以外の画像以外は挿入できません") End If End Sub 上のコードを実行するとなぜか120×90以外でも メッセージが表示されなくなります （Msgbox a.Width * 4 / 3は90 Msgbox a.Height * 4 / 3は120と正しく表示されます） 更に高さが1px多くなってしまいます（-1） （高さを調べても121pxではなく120pxでした） たまにvbaをしている時にあるので 回答と原因もお願いします

  • excel　マクロ　画像挿入

    以下のマクロでリンク貼り付けではない　画像挿入を作成しようと思いましたがエラーになります 詳しい方　修正　お願いいたします 当方のしたい事としましては 選択したセルでのみに画像挿入　リンクではない画像貼り付け 以下例では　B3,B17,B31,B46,B60,B74　セルをダブルクリックすればそこに画像を挿入です Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double If Not Intersect(Range("B3,B17,B31,B46,B60,B74"), Target) Is Nothing Then myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" Exit Sub End If '===============画像の掃除 For Each mySp In ActiveSheet.Shapes myAD1 = mySp.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySp.Delete Next '===============画像の貼り付け Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _ SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _ Width:=0, Height:=0) '★　とりあえず　縦横０で。 mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す '===============タテヨコの縮尺を保持 If mySp.Width > Target.Width Then mySp.Width = Target.Width If mySp.Height > Target.Height Then mySp.Height = Target.Height '===============中央へ調整 myHH2 = (Target.Height / 2) - (mySp.Height / 2) myWW2 = (Target.Width / 2) - (mySp.Width / 2) mySp.Top = Target.Top + myHH2 mySp.Left = Target.Left + myWW2 Set mySp = Nothing End Sub

  • エクセル２０１０　挿入画像の圧縮　VBA

    お世話になります。 エクセル２０１０を使用しています。写真帳を作成しダブルクリックすれば写真が挿入されるようVBAにて作成しましたが、写真の解像度が高いので挿入するたびに画像が圧縮するようにVBAを組みたいのですが、どなたかご教示ください。 具体的には一同挿入した画像を一度コピーし、再度貼り付ける・・・という動作かなと考えているのですが、マクロの記憶では記録されず・・・困っております。 現在の写真帳の構文は Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double '挿入のセルを指定 If Application.Intersect(Target, Range("d6,d23,d40")) Is Nothing Then Exit Sub Cancel = True Application.ScreenUpdating = False End If '写真挿入 Next myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If myPic = False Then MsgBox "画像を選択してください" Exit Sub End If Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Shapes.AddPicture(myPic, False, True, myRange.Left, myRange.Top, myRange.Width, myRange.Height) rX = 0.85 rY = 1 If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 .ZOrder msoSendToBack '最背面へ移動 End With Application.ScreenUpdating = True Cancel = True End Sub 上記に.CUT　などを書き足せばよいのか・・・ →エラーばかりで動かなったので。。 　こちらに質問することにしました。 どうぞ、よろしくお願いします。

  • 画像をエクセルに貼り付けるマクロ

    画像をエクセルに貼り付けるマクロ 複数の画像をエクセルに貼り付ける機会が多く、下記のマクロを利用しています。これは他人が作ったものでその人が今はいないため修正の仕方がわかりません。 これだとヨコに2個の画像で縦方向に画像が貼り付けられます。これをヨコに3個の画像で 縦方向に画像を貼り付けるようにしたいのですが、方法がわかりません。 お詳しい方どうかよろしくお願いします。 ＜現在＞ １　　２ ３　　４ ５　　６ ＜やりたいこと＞ １　　２　　３ ４　　５　　６ ７　　８　　９ Sub Insertpic() Dim strFilter As String Dim Filenames As Variant Dim pic As picture Dim sc As Range Dim i As Long Dim j As Long Dim k As Long '「ファイルを開く」ダイアログでファイル名を取得 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 ' 貼り付け開始セルを選択 'ActicveCellRange("C5").Select ' マクロ実行中の画面描写を停止 Application.ScreenUpdating = False ' 順番に画像を挿入 For i = LBound(Filenames) To UBound(Filenames) Set pic = ActiveSheet.Pictures.Insert(Filenames(i)) '画像の大きさ指定 With pic.ShapeRange .Height = 120# .Width = 175# .Rotation = 0# End With ' 次の貼り付け先を選択 Select Case i Mod 2 Case 1 '奇数回目 ActiveCell.Offset(, 4).Select Case 0 '偶数回目 ActiveCell.Offset(11, -4).Select End Select Set pic = Nothing Next i ' 終了 Application.ScreenUpdating = True MsgBox i - 1 & "枚の画像を挿入しました", vbInformation End Sub

  • エクセルに写真を挿入するVBA

    エクセルで写真集を作るためのVBAですが、以下のVBAでは画像がリンク貼り付けになってしまいます。どうしたらエクセルファイルに画像を貼りこみで保存できるのでしょうか？ よろしくお願いいたします。 やりたいことは、まずダブルクリックでダイアログボックスを表示させ、挿入したい写真を選択、写真がセルに合わせた大きさに縮小、セルの中央に写真を配置。以上です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ 　　　　　　　　　　　　　　　　　　　　Cancel As Boolean) 　　Dim PicFile As Variant 　　Dim rX As Double, rY As Double 　　'［ファイルを開く］ダイアログボックスを表示 　　PicFile = Application.GetOpenFilename( _ 　　　　　　　　　　　　"画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp") 　　If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub 　　Application.ScreenUpdating = False 　　 　　'画像を挿入 　　With ActiveSheet.Pictures.Insert(PicFile) 　　　　rX = Target.Width / .Width 　　　　rY = Target.Height / .Height 　　　　If rX > rY Then 　　　　　　.Height = .Height * rY 　　　　Else 　　　　　　.Width = .Width * rX 　　　　End If 　　　　'セルの中央（横方向/縦方向の中央）に配置 　　　　.Left = Target.Left + (Target.Width - .Width) / 2 　　　　.Top = Target.Top + (Target.Height - .Height) / 2 　　End With 　　 　　Application.ScreenUpdating = True 　　Cancel = True End Sub

  • エクセルvbaに関する質問です

    ExecuteExcel4Macroを使った際について質問があります。 別ブックのセルを参照したいために、ExecuteExcel4Macroを使いました。 1つ目のmsgboxではパスを変数で、二つ目のmsgboxではパスを直書きしています。 下記のサンプルプログラムで2つとも同じものを表示させたいのですが、別の結果が表示されます。 =====サンプルプログラム＝＝＝＝＝ Sub Sample1() Dim name As String Dim path As String Dim sheet As String path = "C:\Users\USER\Desktop\シフト表\新しいフォルダ\" name = "book1.xls" sheet = "Sheet1" Application.DisplayAlerts = False MsgBox ExecuteExcel4Macro("'" & path & "[" & name & "]" & sheet & "'!R1C1") MsgBox ExecuteExcel4Macro("'C:\Users\USER\Desktop\シフト表\新しいフォルダー\[book1.xls]Sheet1'!R1C1") Application.DisplayAlerts = True End Sub ＝＝＝ここまで＝＝＝＝＝ 実際のbook1.xlsのA1セルには「1」が入っているのですが、変数で書いた場合のみ「aaaaaa」が表示されます。 どうかご教授いただけたら幸いです。

  • エクセルのマクロで画像を貼り付け　

    画像をエクセルに貼り付ける作業を行っています。 マクロを使いファイル内の画像（約３０枚程度）を１列づつスペースを空け 右方向に４枚 １行スペースを空け ３行目の左に戻り その位置よりまた１列づつスペースを空け右方向に４枚・・・・・ これを繰り返しファイル内の画像をすべて 貼り付けたいのですがうまく動作が出来ません。 何卒ご教授の程よろしくお願いします。 ※マクロ Sub EggFunc_pasteDirImage() ' 変数定義 Dim fileName As String Dim targetCol As Integer Dim targetRow As Integer Dim targetCell As Range Dim shell, myPath Dim pos As Integer Dim extention As String Dim isImage As Boolean ' 選択セルを取得 targetCol = ActiveCell.Column targetRow = ActiveCell.Row ' フォルダ選択画面を表示 Set shell = CreateObject("Shell.Application") Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\Users\0602116.MS\Desktop\") Set shell = Nothing ' フォルダを選択したら... If Not myPath Is Nothing Then fileName = Dir(myPath.Items.Item.Path + "\") Do While fileName <> "" ' ファイル拡張子の判別 isImage = True pos = InStrRev(fileName, ".") If pos > 0 Then Select Case LCase(Mid(fileName, pos + 1)) Case "jpeg" Case "jpg" Case "gif" Case Else isImage = False End Select Else isImage = False End If ' 拡張子が画像であれば If isImage = True Then ' 貼り付け先を選択 Cells(targetRow, targetCol).Select Set targetCell = ActiveCell ' 画像読込み ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select ' 画像が大きい場合、画像サイズをセル幅に合わせる If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then Selection.Height = Selection.Height * (targetCell.Width / Selection.Width) Selection.Width = targetCell.Width Else Selection.Width = Selection.Width * (targetCell.Height / Selection.Height) Selection.Height = targetCell.Height End If End If ' 表示位置をセル中央に移動 Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) / 2 Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) / 2 ' 貼り付け先行を+1 targetCol = targetCol + 2 End If fileName = Dir() Loop MsgBox "画像の読込みが終了しました" End If End Sub

  • VBA内でのGetPixelを使用した時のRGB値取得の方法

    初めまして、 現在、ExcelVBAを勉強中です。 表題の通りですが、LoadPicture関数でbmpを読み込み、ピクセルのRGB値を取得しようとしているのですがうまくいきません。色々と検索して回ったのですが、探し方が悪いのか見つかりませんでした。 以下はソースになります。 Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long Sub Sample(bmpfile as String) bmpdata = LoadPicture(bmpfile) 'デバッグ用表示 MsgBox (Hex(GetPixel(bmpdata, 1, 1))) End Sub サンプルで使用した画像データは10x10のすべて黒(#000000)で塗りつぶしたデータですが、デバッグ表示で見てみると何故かFFFFFFFFと表示されます。ほかの色も試しましたがデバッグ表示結果は同じでした。 どなたか詳しい方、原因などを教えて頂けますでしょうか。 よろしくお願いいたします。

  • エクセル マクロ 画像についての質問です。

    エクセル マクロについての質問です。 下記のコードでセルに画像を合わせて貼り付け、表を作成しています。 が、このコードだと画像の保存先を移動させると画像が表示されなくなり、分類でフィルターをかけるとバラバラの違う画像が表示されてしまったりして困っています・・・。 どなたか良いご意見を頂ければと思い、投稿しました。よろしくお願いします！ Sub PictFit() Dim PicFile As String Dim Pic As Picture PicFile = Application.GetOpenFilename() '画像のパスを取得 If PicFile = "False" Then Exit Sub Set Pic = ActiveSheet.Pictures.Insert(PicFile) '画像を貼り付ける With Pic .Height = ActiveCell.MergeArea.Height '画像の高さ .Top = ActiveCell.Top '画像の上位置を変更 .Left = ActiveCell.Left + (ActiveCell.MergeArea.Width - .Width) / 2 '画像の横位置を変更(セル幅中央に画像中央) End With End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する