Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Home : Excel 2016)
工事台帳に写真撮影日付を挿入したい
投稿日時: 19/06/06 14:50:14
投稿者: いっくんママ

超初心者ですが工事写真台帳を作成しています。
VBAという方法でエクセルに工事写真をダブルクリックで挿入出きるようになったのですが、撮影日付けを別セルに挿入する方法をネットで調べてもわかりません。
 
画像をダブルクリックでエクセルに貼る方法は Worksheet, Before Double Clickに下記を貼りました。
撮影日を別セルに挿入する方法を超初心者にもわかりやすいように教えていただけると助かります。
よろしくお願い致します。
 
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

回答
投稿日時: 19/06/06 15:31:24
投稿者: WinArrow
投稿者のウェブサイトに移動
投稿日時: 19/06/06 16:11:40
投稿者: いっくんママ

WinArrow様
早速回答ありがとうございます。
超初心者の為どこに何をしたらよいのかわからないです。
せっかく教えていただいたのに申し訳ございません。

回答
投稿日時: 19/06/06 18:22:35
投稿者: WinArrow
投稿者のウェブサイトに移動

 
撮影日時取得のコードを紹介します。
  
どこに組み込むかは、貴方が判断してください。
  
実行できるコードを貰った
 で、終わりにしないで下さい。
  
いただいたコードの1行ごとに
 その目的や意味を理解することが大事なことです。
  
現在実行しているコードを理解していれば、
どこの組み込んだらよいかはわかるはずです。
 
Sub test()
    Dim ObjShell As Object
    Dim ObjFolder As Object
    Dim FolderName As Variant
    Dim myTExt As String
    Dim PicFile As String
    Dim myFileName As String
     
    PicFile = Application.GetOpenFilename( _
                         "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
    FolderName = Left$(PicFile, InStrRev(PicFile, "\") - 1)
    myFileName = Mid$(PicFile, InStrRev(PicFile, "\") + 1)
    Set ObjShell = CreateObject("Shell.Application")
    Set ObjFolder = ObjShell.Namespace(FolderName)
    myTExt = ObjFolder.GetDetailsOf(ObjFolder.ParseName(myFileName), 12)
    myTExt = Mid(myTExt, 2, 5) & Mid(myTExt, 8, 3) & Mid(myTExt, 12, 3) & Mid(myTExt, 17)
    MsgBox myTExt
 
End Sub
 
GetOpenfileNameメソッドでえしているている
画像の拡張子の中で、撮影日時が存在しないものがあります。
そのあたりも判断しましょうね・・・

回答
投稿日時: 19/06/06 19:55:17
投稿者: mattuwan44

自分で自作する時間がもったいないですよ^^;
 
https://www.wise.co.jp/quickproject/pm/
↑1年間フリーなうえ、買っても9800円です。
会社で買ってもらいましょう。
試用期間が過ぎても一部機能が使えないだけなので、
ちょっと整理するくらいなら、特に問題ないかもです。
 
そんな大げさなものは要らないよ。という事なら、
http://syashintyou.mocemoce.com/
こんなの見つかりました。
 
こんなのも。。。
https://kspc-biz.com/kaisetsu/pcit/180129exceldaichoukanri/
メルマガ購読で無料?メールがうるさいかも><
 
その他探せばいろいろありそうです。
 
ま、自作できれば、痒いところに手が届くわけですが、
本業の合間にVBAの勉強は結構厳しいかもです。
 
自分は土木系が本業ですが、
合間に(さぼって?)VBA勉強してます。
自分だけが使うなら、エラーが出たり不具合があっても、
その場でどうにか対処できるのですが、
使えるソフト(他人に使ってもらえるソフト)を作るのはなかなか難しいです。

投稿日時: 19/06/07 09:52:38
投稿者: いっくんママ

 WinArrow様
まったくその通りです。ご意見ありがとうございます。
頑張ってみます。

投稿日時: 19/06/07 09:55:22
投稿者: いっくんママ

 mattuwan44
ご回答ありがとうございます。
これからな頑張ってやってみます。

回答
投稿日時: 19/06/08 12:12:40
投稿者: mattuwan44

Option Explicit

'***********************************************
'Microsoft Scripting Runtimeを参照設定すること
'***********************************************

Private Type PictureInfo
    FullPath As String
    BaseName As String
    Date As Variant
End Type

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim FSO As FileSystemObject
    Dim picInfo As PictureInfo
    Dim Pic As Picture
    Dim i As Long
    Const cMargin As Double = 5

    Cancel = True
    Set FSO = New FileSystemObject
    If GetPictureInfo(picInfo, FSO) = False Then Exit Sub
    Set Pic = Me.Pictures.Insert(picInfo.FullPath)

    With Target
        i = .Columns.Count + 1
        .Cells(1, 1).Value = picInfo.FullPath
        .Cells(1, i).Value = picInfo.BaseName
        .Cells(2, i).Value = picInfo.Date
        Pic.Height = .Height - cMargin
        Pic.Top = .Top + (.Height - Pic.Height) / 2
        Pic.Left = .Left + (.Width - Pic.Width) / 2
    End With
End Sub

Private Function GetPictureInfo(ByRef picInfo As PictureInfo, ByRef FSO As FileSystemObject) As Boolean
    Dim sFilePath As String

    sFilePath = Application.GetOpenFilename("画像ファイル,*.JPG")
    If sFilePath = "False" Then Exit Function
    
    picInfo.FullPath = sFilePath
    picInfo.BaseName = FSO.GetBaseName(sFilePath)
    picInfo.Date = FSO.GetFile(sFilePath).DateCreated
    GetPictureInfo = True
End Function

 
>これからな頑張ってやってみます。
んと、、、、VBAを頑張って勉強するという意味かな?
 
調べながら4時間弱掛かって書いてみました。
撮影日時=ファイルの作成日時として取得してみました。
後で写真を加工や修正とかしたらExifの情報が無かったり、撮影日時とファイルの作成日時が、
変わっているかも知れませんが(コピペしたら変わる?)、その辺は考慮してません。
 
参考URL>>
http://home.att.ne.jp/zeta/gen/excel/c03p07.htm
https://www.relief.jp/docs/fso-vba-references.html
http://officetanaka.net/excel/vba/filesystemobject/
 
↑この辺のサイトを巡回したら、VBAを含むエクセルの大抵の情報がありますよ^^
 
ううう。コピペしたら作成日時が変わりますねー(TT)
Exifの情報を読み取らんとだめかぁ><
 
↓を参考に書いてみてください^^;
http://niwakan.blogspot.com/2016/11/vba-wia-object-exif.html
 
気分転換が長くなってしまった^^;
今日は雨でお休みになったのですが、一人で出社なのです^^;
ネットを巡回せずに、現場を巡回しろって話しですよね^^;;
そろそろ、さすがに仕事しないといけないですよね(爆)
お昼になったのでとりあえず弁当です^^;

回答
投稿日時: 19/06/08 17:49:19
投稿者: mattuwan44

撮影日時を取得するよう修正しました。(たぶん)
 

Option Explicit

'***********************************************
'Microsoft Windows Image Aquisition Library
'Microsoft Scripting Runtime
'を参照設定すること
'***********************************************

Private Type PictureInfo
    FullPath As String
    BaseName As String
    Date As Variant
    LastDate As Variant
End Type

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim picInfo As PictureInfo
    Dim Pic As Picture
    Dim i As Long
    Const cMargin As Double = 5

    Cancel = True
    If GetPictureInfo(picInfo) = False Then Exit Sub
    
    Set Pic = Me.Pictures.Insert(picInfo.FullPath)
    With Target
        i = .Columns.Count + 1
        .Cells(1, i).Value = picInfo.BaseName
        .Cells(2, i).Value = picInfo.Date
        Pic.Height = .Height - cMargin
        Pic.Top = .Top + (.Height - Pic.Height) / 2
        Pic.Left = .Left + (.Width - Pic.Width) / 2
    End With
End Sub

Private Function GetPictureInfo(ByRef picInfo As PictureInfo) As Boolean
    Dim objFSO As Scripting.FileSystemObject
    Dim objImage As WIA.ImageFile
    Dim strFilePath As String
    Const cItemName As String = "ExifDTOrig"
    
    Set objFSO = New Scripting.FileSystemObject
    Set objImage = New WIA.ImageFile
    strFilePath = Application.GetOpenFilename("画像ファイル,*.JPG")
    
    If strFilePath = "False" Then Exit Function
    
    picInfo.FullPath = strFilePath
    picInfo.BaseName = objFSO.GetBaseName(strFilePath)
    objImage.LoadFile strFilePath
    If objImage.Properties.Exists(cItemName) Then
        picInfo.Date = orgDataValue(objImage.Properties(cItemName))
        picInfo.LastDate = orgDataValue(objImage.Properties("DateTime"))
    End If
    GetPictureInfo = True
End Function

Private Function orgDataValue(ByVal s As String) As Date
    Const cDelimiter As String = " "
    Dim v As Variant
    
    v = Split(s, cDelimiter)
    v(0) = Replace(v(0), ":", "/")
    s = Join(v, cDelimiter)
    orgDataValue = CDate(s)
End Function

 
多分、撮影日時は、「ExifDTOrig」の項目だと思うけど、間違ってたらごめんなさいです。
 
勉強した成果が半年で消えちゃうのはつらいですね^^;
 
いまだ、面白そうな課題がないか、掲示板を巡回中^^;;
 
よし、今から本業がんばろー!
(その前にタバコ休憩ですけど^^;)

回答
投稿日時: 19/06/08 18:02:26
投稿者: mattuwan44

>撮影日を別セルに挿入する方法を超初心者にもわかりやすいように教えていただけると助かります
多分今回の件、超初心者には難易度が少し高いかと、思います。
基礎をすっ飛ばして、やりたいことを要求しても身にはつかないでしょう。
そして、どの程度まで理解が進んでいるのかもこちらではわかりませんので、
最初から最後まで解説したら、入門書の何十ページ分書かないといけないか、、、^^;
 
ただ、やりたいことがはっきりしているなら、モチベーションの維持にはつながると思うので、
とりあえずサンプルを読んで、
1行、あるいは1単語をヘルプやネットで調べながら、理解するよう努めましょう。
その上で、解らないことを質問して、少しずつ理解を深めることをお勧めします。
 
「意味解らないけど、上手く動いたからいいや。」で、終わらないことを期待しています。

投稿日時: 19/06/10 10:11:53
投稿者: いっくんママ

 mattuwan44 様
貴重なお時間をお使いいただきご回答感謝です。
今まで利用していた工事写真台帳とは違うタイプの台帳で写真をまとめてほしいと施主からの要望をうけ
たのですが、何の設定もなく画像挿入してサイズもセルフで1枚1枚変更する台帳になっていて大変面倒で困っておりました。当方はVBAなど勉強したことがなく色々調べていたら運よくダブルクリックで画像挿入できるやり方を見つけることが出来助かっていたのですが、写真撮影日を同時に挿入するやり方が全くわからずで困っておりました。運よく見つけたコードはsheet上で右クリックし、コードを貼りつけるという超簡単なやり方です。
今まで利用している台帳は設定済みのものを受け継いだだけなので中身は全くわかりません。
せっかくお調べいただいたのにもかかわらず、どこにこのコードを組み込んだらよいのか?ただコピペすればよいのか?すらわかりません。勉強したいのですが、そうこうしているうちに現場引き渡しになってしまいますので今回は地道に1枚1枚作業していき今後の課題としたいと思います。
mattuwan44 様 本当にお世話になりました、ありがとうございます。
 

回答
投稿日時: 19/06/10 15:50:21
投稿者: WinArrow
投稿者のウェブサイトに移動

いっくんママ さんへ
 
ひとこと・・・・言っておきます。
この掲示板を、会社の仕事の消化するために使うのは、いかがなものかと思います。
 
引き受けた仕事が自分には、スキルがなく、できないと判断したならば、
外注に出せばよいのでは?
この掲示板の回答者を下請けとして使ってはいけません。
 
ご自分のスキルアップのために、質問することはどんどんやってください。
但し、他人が作成した(ネットで検索したら、都合の良いものが見つかったを含む)コードを
そのまま、掲示して、どこを直せばよいか?
というような質問は、やめましょう。これは、コードの作成依頼と変わりません。
スキルアップは、自分なりに勉強するところから始まります。
今回、回答者が作成したコードをそのまま使って、納品できたとしても
施主は、質問や、変更要求をしてきます。
その時、私が作ったと胸を張ってこたえられますか?

トピックに返信