はじめて「生でお願いします!」を使う人が知っておきたいExcelマクロ

毎日「お先に失礼しまっす」というための7つの方法

スポンサーサイト
 

このエントリーをはてなブックマークに追加

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

はじめて「生でお願いします!」を使う人が知っておきたいExcelマクロ
 

このエントリーをはてなブックマークに追加

土木工事現場などでは、記録写真をデジカメで撮ってます。
成果品として提出する写真は、電子納品に対応した専用のソフトで整理していると思います。
その他に発注者、取引業者に資料を渡すときは、写真をExcelに貼り付けて作成することが多くないですか?

Excel(エクセル)にデジカメ写真を貼ったあとに「データくれる?」と言われて、
慌てたことないですか?

ということで、Excel(エクセル)に貼り付けたのデジカメデータ(JPEGデータ)を
抽出するマクロを作ってみました。

作るのはつくったけど、新しいバージョンのエクセルでは使えません!!!
Excel2007~2010 では動作しません。新ネタを考えるのでしばしお待ちを。

・・・しかし、Excel2007以降は貼り付けたデジカメデータは保存するときに
Exifデータが保持されない仕様になったのであまり意味が無いかも・・・

Excel_rJPEG.jpg

1.デジカメデータを貼り付けたExcelファイルを開く
2.マクロ「rJPEG」を実行させます。
  マクロが実行されると、下記の動作を自動で行います。

・開かれているExcelファイルをHTML形式で保存
・HTML形式で保存したときに作成されるJPEGファイルからオリジナルのファイルを
 検索して、指定されたフォルダに保存します。
・HTML形式のファイルはWindowsのTEMPフォルダに保存されて、マクロ終了後に
 削除されます。

【使用上の注意】
Excel2007~2010 では動作しません
 (HTML形式で保存されたときの画像データがPNG形式のため)
・貼り付けたデジカメデータに「Exif情報」が記録されていない場合は、
 このマクロは動作しません。
・すべてのデジカメデータに対して、このマクロが動作する保証はありません。

・デジカメデータを貼り付けたあとに[図の圧縮]コマンドを実行すると
 Exif情報が消えるため、このマクロは動作しません。

・マクロが動かないときは、スパゲッティコードを解読するか、スッパリとあきらめてください。

以下、コードを掲載しますのでご自由に使ってください。
インポート用のBASファイルはDropboxにおいておくのでダウンロードして使ってください。

Dropboxを使ったことがない人は「ここから」アカウントとって利用してください。

※このマクロを利用して発生したデータの消失・破損等については一切責任を負いません。
 Excel(エクセル) VBAが理解出来ない人は使用しないでください。

※出来る限り質問等には答えますが、基本的には自己責任でお願いします。

メキメキ上達! エクセル関数ワザ100(日経ビジネス人文庫)
日経PC21
日本経済新聞出版社
売り上げランキング: 1695

Option Explicit

'Byteデータを読み込むユーザー定義型
Type T_APP1 'Exifが埋め込まれていれば
head(1 To 4) As Byte 'FF D8 FF E1 となる
size(1 To 2) As Byte '
exif(1 To 6) As Byte 'Exif0000
End Type

'APP0がある場合の対応
Type T_APP0
head0(1 To 18) As Byte
head(1 To 4) As Byte
size(1 To 2) As Byte
exif(1 To 6) As Byte

End Type

Sub rJPEG()

Dim objJpeg As Object

Dim strFilename As String
Dim strFolder As String, strSaveFolder As String

Dim strUseName() As Variant
Dim strWidth() As Variant

Dim app1 As T_APP1
Dim app0 As T_APP0

Dim tmp As String
Dim FILE_PATH As String

'HTML形式で保存されるときのファイル名 デフォルトは「hogehoge.htm」
Dim strSaveName As String: strSaveName = "hogehoge.htm"

Dim WSH As Variant

Dim inumA As Integer, inumB As Integer, inumU As Integer 'カウンタ用

'--------------------------------
'Excelのバージョンを調べる
'--------------------------------
'2007未満2000以上

If CInt(Application.Version) >= 12 Or CInt(Application.Version) < 9 Then Exit Sub

'--------------------------------
'ブックをHTML形式で保存する
'--------------------------------
'アクティブブックをxls形式で上書き保存
'マクロ実行後は実行対象ファイルはHTML形式で保存されて、
'マクロ終了後に破棄される。必ず上書きを実行すること。

If MsgBox("マクロを実行する前に上書き保存します。" & Chr(10) & "よろしいですか?", vbOKCancel) = vbOK Then
ActiveWorkbook.Save
Else
'上書き保存がされない場合はマクロを停止
MsgBox "上書き保存してください"
Exit Sub
End If

'TEMPフォルダを取得する
Set WSH = CreateObject("WScript.Shell")
strFolder = TEMP() & "\"

'マイドキュメントに作業用のフォルダを作成する
'TEMPフォルダに作成する作業用フォルダは任意に作成可能。
'デフォルトは「hogehoge」
If Dir(strFolder & "hogehoge", vbDirectory) = vbNullString Then

MkDir strFolder & "hogehoge"

End If

strFolder = strFolder & "hogehoge" & "\"

'アクティブブックをHTML形式で保存する
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs strFolder & strSaveName, xlHtml

'HTML形式で保存すると貼りつけてあるデジカメデータは
'JPEGファイルで保存されるのでそれを読み込んでいく。
strFilename = Dir(strFolder & "hogehoge.files" & "\" & "*.JPG", vbNormal)

inumA = 0

ReDim strUseName(inumA)

Do Until Len(strFilename) = 0

'HTML形式で保存されたときに一緒に保存されるJPEGファイルは、
'オリジナルサイズとサムネイルの2種類がある。
'オリジナルサイズにはExifデータがあるので、Exifデータが
'記録されているJPEGファイルのみを抜き出す。


FILE_PATH = strFolder & "hogehoge.files" & "\" & strFilename

Open FILE_PATH For Binary Access Read As #1

'Exifデータがあるか調べる
Get #1, , app1
tmp = "Exif" & Chr(0) & Chr(0)

If app1.head(1) = &HFF And app1.head(2) = &HD8 And app1.head(3) = &HFF And app1.head(4) = &HE1 Then

strUseName(inumA) = strFilename

inumA = inumA + 1
ReDim Preserve strUseName(inumA)

ElseIf app1.head(1) = &HFF And app1.head(2) = &HD8 And app1.head(3) = &HFF And app1.head(4) = &HE0 Then

Close #1

Open FILE_PATH For Binary Access Read As #2
Get #2, , app0

If app0.exif(1) = &H45 And app0.exif(2) = &H78 And app0.exif(3) = &H69 And app0.exif(4) = &H66 Then

strUseName(inumA) = strFilename

inumA = inumA + 1
ReDim Preserve strUseName(inumA)

End If

End If


Close #1
Close #2

strFilename = Dir

Loop

inumU = UBound(strUseName)

If inumU = 0 Then
delhtml (strFolder & "\")
Exit Sub
End If

'JPEGファイルを保存するフォルダを選択する。
With Application.FileDialog(msoFileDialogFolderPicker)

If .Show = True Then
strSaveFolder = .SelectedItems(1)
End If

'保存するフォルダが選択されないとき
'再度、フォルダの選択を促す

If strSaveFolder = "" Then
MsgBox "フォルダを選択してください"

If .Show = True Then
strSaveFolder = .SelectedItems(1)
Else
MsgBox "フォルダが選択されませんでした"
delhtml (strFolder)
Exit Sub

End If

End If

End With


'Exif データあるJPEGを選択したフォルダにコピーする
For inumB = 0 To inumU - 1

FileCopy strFolder & "hogehoge.files" & "\" & strUseName(inumB), strSaveFolder & "\" & strUseName(inumB)

Next

'TEMPフォルダに保存されたHTML形式のファイルを削除する
delhtml (strFolder)

End Sub


'TEMPフォルダに保存されたHTML形式のファイルを削除する
Sub delhtml(strFol As String)

Dim numTempName As Integer
Dim strKillName As String

With Workbooks("hogehoge.htm")
.Saved = True
.Close
End With

numTempName = Len(strFol)

strKillName = strFol & "hogehoge.files" & "\" & "*.*"
Kill strKillName
RmDir strFol & "hogehoge.files"

strKillName = strFol & "*.*"
Kill strKillName
RmDir Mid(strFol, 1, numTempName - 1)

End Sub

'WindowsのTEMPフォルダを取得する
Function TEMP()

Dim strTemp As Scripting.FileSystemObject

Set strTemp = New Scripting.FileSystemObject

'Windows tempフォルダパス取得
TEMP = strTemp.GetSpecialFolder(TemporaryFolder).Path

End Function

この記事へのコメント
URL:
Comment:
Pass:
秘密: 管理者にだけ表示を許可する
 
この記事のトラックバックURL
http://excel555.blog58.fc2.com/tb.php/123-3b399599
この記事にトラックバックする(FC2ブログユーザー)
この記事へのトラックバック

 | Copyright © お先に失礼しまっす! All rights reserved. | 

 / Template by 無料ブログ テンプレート カスタマイズ
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。