LoginSignup
0
0
@Lile_des_Pains(イル)

Windowsタブレットで写真撮影し、エクセルに貼り付ける

Posted at

警告
　初投稿となりますので、稚拙な文章となりますので、それを踏まえた上でご覧下さい。
　素人コードですので、リファクタリングされていない・コメントが不十分・なぜ日本語関数？など色々見にくい点が多いと思います。ご指摘ございましたら、どしどしコメントお願い致します。
　また、日本語関数・変数については、次の人に引継ぎする際、少しでも親しみやすい言葉でプログラムを書いております。ご了承のほどお願いいたします。

このプログラムを作ることになった経緯

「現場にタブレットを持っていき、写真を撮ったらエクセルに自動で貼りつく様、作って欲しい。」
突然、上司の無茶振りが発動しました。
私は、趣味でswiftを勉強し、ついでに業務で使っているエクセルの自動化に挑戦してみたりする平凡な一般事務の人間にそんな無茶振りをしてくる。

「やれるだけやってみます。出来ない可能性はありますけど...」と答えた。
やり方は、全く頭に浮かんでいない。イチから調べるしかない。
だが、プログラミングをかじった人なら理解出来るのではないだろうか？
無理難題なことでも挑戦して自動化出来たら、チョー気持ちいい！
腕試し気分で取り組むこととなった。

プログラムの流れ

1.　エクセルを開ける。
2.　フォームを起動。
3. フォームと同時にカメラアプリ起動。
4. フォームにあるボタンを押すと、セルに写真が貼りつく。
5. 削除ボタンを押すと、セルの写真が消える。
6. フォームの閉じるボタンで、フォームとカメラアプリを閉じる。

1.エクセルからカメラを起動させる。

ここでは、シェルを使ってカメラアプリを起動させております。
waitを使って、起動後すぐに撮影ボタンが押されない様にしております。
カメラが起動しない内に押すトラブルを防ぐため。

カメラ.bas
Sub カメラ起動()

    Set objCamera = CreateObject("WScript.Shell")
   
    objCamera.Run "shell:AppsFolder\Microsoft.WindowsCamera_8wekyb3d8bbwe!App"
    Application.Wait Now + TimeValue("0:00:01")
   
End Sub

2.フォームの作成

まず、フォームを以下の様に作ります。
※ボタンそれぞれに分かりやすい名前を付けておきましょう。
（今回撮影用ボタン名は、camera1・camera2。削除ボタンは、gomi1・gomi2。）
（フォーム名：シャッターボタン）
image.png

3.モジュールからフォームの作成

さきほど作成したフォームを起動する関数を作成。
カメラもフォームを同時起動させる。

formshow.bas
Sub formshow()
    Load シャッターボタン
 
    Call カメラ起動
    
    シャッターボタン.StartUpPosition = 3
    シャッターボタン.Show
End Sub

4.フォームの中身を作成

4-1.撮影ボタンの作成

シャッターボタン.fm
Const 一番 As String = "A13:B13"  '貼り付けたいセル
Const 二番 As String = "C13:D13"　'貼り付けたいセル

'################　撮影ボタン　################
Private Sub camera1_Click()
    撮影(一番)
    
End Sub

Private Sub camera2_Click()
    撮影(二番)
    
End Sub

'################　撮影ボタン定義　################
Private Sub 撮影(RangeStr As String)
   Application.Wait Now + (0.1 / 86400)
  
    'カメラのシャッターを押す
    AppActivate "カメラ", True
    SendKeys "{ENTER}", True
End Sub

4-2.撮影ボタンをより良くする。

　カメラボタンを押して、反映されるまで時間が掛かるため、
現在実行中であることを撮影者に知らせる仕組み。
（暗に『何回も押すなよ！』ってこと）
（後ほど作成する貼り付け処理の反映に時間が掛かるため）

シャッターボタン.fm
'################　撮影ボタン定義　################
Private Sub 撮影(RangeStr As String)
    Call 取り込み中表示(RangeStr)
    
    Application.Wait Now + (0.1 / 86400)
  
    'カメラのシャッターを押す
    AppActivate "カメラ", True
    SendKeys "{ENTER}", True
    
    'カメラが保存する時間を待つ
    Application.Wait Now + TimeValue(waitTime)
    
    Call 取り込み中終了(RangeStr)
End Sub

'################　取り込み中表示　################
Sub 取り込み中表示(str As String)
    range(str).Value = "取り込み中..."

End Sub
Sub 取り込み中終了(str As String)
    range(str).Value = ""
    
End Sub

5.貼り付け関数作成

5-1最新のカメラロールから写真を取得。写真を一度エクセルに貼り付ける。

貼り付け.bas
Private Sub 最新カメラロールからファイル取得挿入()
    Dim folderPath As String
    Dim latestFile As String
    
    ' マイピクチャフォルダのパスを取得する
    Dim profile As String
    profile = Environ("USERPROFILE")
    folderPath = profile & "\Pictures\Camera Roll\"
   
    ' カメラロールの最新のファイルを取得する
    Dim latestDate As Date
    latestDate = DateSerial(1900, 1, 1)
    
    Dim file As String
    file = Dir(folderPath & "*.*")
    Do While file <> ""
        If file Like "*.jpg" Or file Like "*.png" Or file Like "*.bmp" Then
            Dim fileDate As Date
            fileDate = FileDateTime(folderPath & file)
            
            If fileDate > latestDate Then
                latestDate = fileDate
                latestFile = file
                
            End If
            
        End If
        
        file = Dir
        
    Loop
            
   ActiveSheet.Pictures.Insert(folderPath & latestFile).Select
   
End Sub

5-2　貼り付けられた写真をセルのサイズに合うように調整する

貼り付け.bas
Private Sub 写真貼り付けサイズ調整カット(写真, Target As String)
    Call サイズ調整(写真, Target)

    写真.Cut '写真のカット（縦横を確定させる。写真には回転の情報がないため）
    
End Sub

Private Sub 写真ペーストから再度大きさ調整と位置調整(Target As String)
 
    ActiveSheet.PasteSpecial Format:=1, Link:=False

    Call サイズ調整(Selection.ShapeRange, Target)
        
    With Selection.ShapeRange
        .Left = Range(Target).Left + (Range(Target).Width - .Width) / 2 '写真の横位置をセルの中央へ
        .Top = Range(Target).Top + (Range(Target).Height - .Height) / 2 '写真の縦位置をセルの中央へ
    End With

End Sub

Private Sub サイズ調整(写真, Target As String)
    With 写真
        If .Width > Range(Target).Width Then
            .Width = Range(Target).Width - 5 '写真の幅をセルの幅に合わせる
        ElseIf .Height > Range(Target).Height Then
            .Height = Range(Target).Height - 5 '写真の高さをセルの高さに合わせる
        End If

    End With

End Sub

5-1,5-2のプログラムを統合する

貼り付け.bas
Public Sub 貼り付け(Target As String)
        Dim myFile
        Dim 写真 As Object
    
        Call 最新カメラロールからファイル取得挿入
        
        Set 写真 = Selection
        
        Call 写真貼り付けサイズ調整カット(写真, Target)
        
        Set 写真 = Nothing '若干早くメモリ解放
        
        Call 写真ペーストから再度大きさ調整と位置調整(Target)
        
End Sub
貼り付け.bas(全文）
Public Sub 貼り付け(Target As String)
        Dim myFile
        Dim 写真 As Object
    
        Call 最新カメラロールからファイル取得挿入
        
        Set 写真 = Selection
        
        Call 写真貼り付けサイズ調整カット(写真, Target)
        
        Set 写真 = Nothing '若干早くメモリ解放
        
        Call 写真ペーストから再度大きさ調整と位置調整(Target)
        
End Sub

Private Sub 最新カメラロールからファイル取得挿入()
    Dim folderPath As String
    Dim latestFile As String
    
    ' マイピクチャフォルダのパスを取得する
    Dim profile As String
    profile = Environ("USERPROFILE")
    folderPath = profile & "\Pictures\Camera Roll\"
   
    ' カメラロールの最新のファイルを取得する
    Dim latestDate As Date
    latestDate = DateSerial(1900, 1, 1)
    
    Dim file As String
    file = Dir(folderPath & "*.*")
    Do While file <> ""
        If file Like "*.jpg" Or file Like "*.png" Or file Like "*.bmp" Then
            Dim fileDate As Date
            fileDate = FileDateTime(folderPath & file)
            
            If fileDate > latestDate Then
                latestDate = fileDate
                latestFile = file
                
            End If
            
        End If
        
        file = Dir
        
    Loop
            
   ActiveSheet.Pictures.Insert(folderPath & latestFile).Select
   
End Sub

Private Sub 写真貼り付けサイズ調整カット(写真, Target As String)
    Call サイズ調整(写真, Target)

    写真.Cut '写真のカット（縦横を確定させる。写真には回転の情報がないため）
    
End Sub

Private Sub 写真ペーストから再度大きさ調整と位置調整(Target As String)
 
    ActiveSheet.PasteSpecial Format:=1, Link:=False

    Call サイズ調整(Selection.ShapeRange, Target)
        
    With Selection.ShapeRange
        .Left = Range(Target).Left + (Range(Target).Width - .Width) / 2 '写真の横位置をセルの中央へ
        .Top = Range(Target).Top + (Range(Target).Height - .Height) / 2 '写真の縦位置をセルの中央へ
    End With

End Sub

Private Sub サイズ調整(写真, Target As String)
    With 写真
        If .Width > Range(Target).Width Then
            .Width = Range(Target).Width - 5 '写真の幅をセルの幅に合わせる
        ElseIf .Height > Range(Target).Height Then
            .Height = Range(Target).Height - 5 '写真の高さをセルの高さに合わせる
        End If

    End With

End Sub

6.撮影ボタンに貼り付け処理統合

ついでにエクセル処理負荷を軽減させる処理も追加

シャッターボタン.fm　
'################　撮影ボタン定義　################
Private Sub 撮影(RangeStr As String)
    Call 取り込み中表示(RangeStr)
    
    Application.Wait Now + (0.1 / 86400)
  
    'カメラのシャッターを押す
    AppActivate "カメラ", True
    SendKeys "{ENTER}", True
    
    Call 高速開始

    Call 貼り付け(range(RangeStr))

    Call 高速終了
    
    Call 取り込み中終了(RangeStr)
End Sub
高速化.bas
Sub 高速開始()
      With Application
            .ScreenUpdating = False '画面描画を停止
            .EnableEvents = False 'イベントを抑止
            .DisplayAlerts = False '確認メッセージを抑止
      End With
End Sub

Sub 高速終了()
      With Application
            .StatusBar = False 'ステータスバーを消す
            .DisplayAlerts = True '確認メッセージを開始
            .EnableEvents = True 'イベントを開始
            .ScreenUpdating = True '画面描画を開始
      End With
End Sub

7.撮影ボタンを押してから写真が保存されるまで、タイムラグがある為、waitで調整。

（保存される前に貼り付け処理をされると、一個前の写真が貼りつく為）
ファイルのサイズを取得して、サイズによって、待ち時間を調整。
（待ち時間については、スペックにより調整してください。）

シャッターボタン.fm　
'################　撮影ボタン定義　################
Private Sub 撮影(RangeStr As String)
    Call 取り込み中表示(RangeStr)
    
    Application.Wait Now + (0.1 / 86400)
  
    'カメラのシャッターを押す
    AppActivate "カメラ", True
    SendKeys "{ENTER}", True
    
    Call 高速開始

    'ファイルサイズを調べる
    Dim size As Long
    size = FileSize取得

    'ファイルサイズからwaitTimeを設定する
    Dim waitTime As String
    waitTime = WaitTime設定(size)

    'カメラが保存する時間を待つ
    Application.Wait Now + TimeValue(waitTime)

    Call 貼り付け(range(RangeStr))

    Call 高速終了
    
    Call 取り込み中終了(RangeStr)
End Sub
'################　FileSize取得　################
Function FileSize取得()
    Dim fileSize As Long
    
    fileSize = FileLen(ActiveWorkbook.FullName)
    
    FileSize取得 = fileSize

End Function

'################　WaitTime設定　################
Function WaitTime設定(size As Long)
    Select Case size
    Case 0 < 300000:
        WaitTime設定 = "0:00:01"
    Case 300001 To 600000
        WaitTime設定 = "0:00:02"
    Case 600001 To 900000
        WaitTime設定 = "0:00:03"
    Case Else
        WaitTime設定 = "0:00:05"
    End Select
End Function

7.削除ボタンの処理実装にて完成

シャッターボタン.fm　
'################　削除　################
Private Sub gomi1_Click()
    DeleteShapesInRange (一番)
    
End Sub

Private Sub gomi2_Click()
    DeleteShapesInRange (二番)
    
End Sub

'################　削除定義　################
Sub DeleteShapesInRange(RangeStr As String)
    Dim pic As Shape
    Dim rng As range
    Set rng = range(RangeStr)
    
    For Each pic In rng.Parent.Shapes
        If Not pic.Type = msoPicture Then
            GoTo Continue '画像でない場合は、次のシェイプを処理する
            
        End If
        
        If Intersect(pic.TopLeftCell, rng) Is Nothing Then
           GoTo Continue '範囲外の場合は、次のシェイプを処理する
           
        End If
        
        pic.Delete '画像を削除する
        
Continue:
    Next pic
End Sub

下記にシャッターボタン.fmの全文を載せます。

シャッターボタン.fm　（全文）
Const 一番 As String = "A13:B13" 
Const 二番 As String = "C13:D13"

'################　撮影ボタン　################
Private Sub camera1_Click()
    CommonFunction (一番)
    
End Sub

Private Sub camera2_Click()
    CommonFunction (二番)
    
End Sub

'################　撮影ボタン定義　################
Private Sub 撮影(RangeStr As String)
    Call 取り込み中表示(RangeStr)
    
    Application.Wait Now + (0.1 / 86400)
  
    'カメラのシャッターを押す
    AppActivate "カメラ", True
    SendKeys "{ENTER}", True
    
    Call 高速開始

    'ファイルサイズを調べる
    Dim size As Long
    size = FileSize取得

    'ファイルサイズからwaitTimeを設定する
    Dim waitTime As String
    waitTime = WaitTime設定(size)

    'カメラが保存する時間を待つ
    Application.Wait Now + TimeValue(waitTime)

    Call 貼り付け(range(RangeStr))

    Call 高速終了
    
    Call 取り込み中終了(RangeStr)
End Sub

'################　取り込み中表示　################
Sub 取り込み中表示(str As String)
    range(str).Value = "取り込み中..."

End Sub
Sub 取り込み中終了(str As String)
    range(str).Value = ""
    
End Sub

'################　FileSize取得　################
Function FileSize取得()
    Dim fileSize As Long
    
    fileSize = FileLen(ActiveWorkbook.FullName)
    
    FileSize取得 = fileSize

End Function

'################　WaitTime設定　################
Function WaitTime設定(size As Long)
    Select Case size
    Case 0 < 300000:
        WaitTime設定 = "0:00:01"
    Case 300001 To 600000
        WaitTime設定 = "0:00:02"
    Case 600001 To 900000
        WaitTime設定 = "0:00:03"
    Case Else
        WaitTime設定 = "0:00:05"
    End Select
End Function

'################　削除　################
Private Sub gomi1_Click()
    DeleteShapesInRange (一番)
    
End Sub

Private Sub gomi2_Click()
    DeleteShapesInRange (二番)
    
End Sub

'################　削除定義　################
Sub DeleteShapesInRange(RangeStr As String)
    Dim pic As Shape
    Dim rng As range
    Set rng = range(RangeStr)
    
    For Each pic In rng.Parent.Shapes
        If Not pic.Type = msoPicture Then
            GoTo Continue '画像でない場合は、次のシェイプを処理する
            
        End If
        
        If Intersect(pic.TopLeftCell, rng) Is Nothing Then
           GoTo Continue '範囲外の場合は、次のシェイプを処理する
           
        End If
        
        pic.Delete '画像を削除する
        
Continue:
    Next pic
End Sub

苦労した点

・エクセルから直接カメラの読込や操作が出来ない。（調べても見つからず）
・カメラアプリの撮影ボタンを押すと、貼り付けできない。（必ずフォームから操作必須）

あとがき

エクセルからカメラ起動させる方法を色々模索しました。
バッチファイルを起動させる方法やシェルを起動し、そのファイルから起動させたり...。
時間が掛かりましたが、何とか動作する形を作ることが出来ました。
まだまだ、コードも稚拙で醜いと思いますので、コメントでご指摘いただければ、ありがたいです。

アウトプット駆動開発の精神で投稿しました。
たった一人でもこの記事でお役に立てる事が出来れば幸いです。
そして、自分の成長記録として残していきます。

今後とも末永く宜しくお願い致します。

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0