DuKiccoの雑記

My Life Is Myself

【画像処理、ImageMagickをエクセルVBAから使う】

エクセル VBA

目的
様々な画像処理をVBAから行う。
画像処理例
・フォルダ内の画像ファイルを一括で縮小やリサイズを行う
・フォルダ内の画像ファイルを一括で別形式に変換する（→jpg,png,pdf,etc)
・フォルダ内のjpgファイルをまとめ1つのpdfファイルにする
・画像ファイルのサイズ等の情報を取得する
・2つの画像を合成する


上記の内容はVBA単独では難しいのでフリーソフトのImageMagickをVBAから利用できるようにする。
ImageMagickとは？

www.atmarkit.co.jp


準備
1.ImageMagickのダウンロード
Windowsのbit数ではなく使用するOfficeのbit数に合わせるとのこと
http://www.imagemagick.org/script/binary-releases.php
f:id:DuKicco:20160607070453j:plain

2.ImageMagickのインストール
VBAから利用できるように「Install ImageMagickObject OLE Control for VBScript, Visual Basic, and WSH」にチェックを入れる
f:id:DuKicco:20160607070407j:plain


3.VBAでのImageMagicObjectの参照設定にチェクを入れる
f:id:DuKicco:20160607070432j:plain


以下、実例

Sub ImageMagick一括圧縮()
'指定したフォルダ内の画像(jpg)を一括し圧縮する（上書き）
Dim FolPath As String

'任意のフォルダを選択
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = titlestr
        If .Show = -1 Then
            FolPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
End With

   Set img = New ImageMagickObject.MagickImage
   
   Debug.Print img.Identify("-format", "%h", FolPath & "\*.jpg") '選択前のサイズを出力
   
   img.Mogrify "-resize", "65%", FolPath & "\*.jpg" '選択したフォルダ内のjpgを65%圧縮。上書きモード注意！
   
   Debug.Print img.Identify("-format", "%h", FolPath & "\*.jpg") '選択後のサイズを出力
   Set img = Nothing
   
End Sub

【Web上のファイルや画像をダウンロード、URLDownloadToFile】【VBA】

エクセル VBA

Web上のファイルをダウンロードする際に

・ファイルのURLに法則性があり機械的に決まっている。
・ダウンロードしたファイル名を自分で決めて保存したい。

といったケースに大変便利です。

例えばYahooFinanceのトヨタ自動車（証券コード7203)の日足チャートは以下のようにURLが決まっています。
以下の日足チャートをダウンロードしてみます。

"http://chart.yahoo.co.jp/?code=7203.T&tm=1y&type=c&log=off&size=m&over=m65,m130,s&add=vm,ss&comp="


f:id:DuKicco:20160606074254j:plain


ちなみに証券コード(7203)部分を書き換えると他社の日足チャートになります。

'宣言部に以下の記述が必要

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub testURLD()
'指定した証券コードの日足チャートを本ファイルと同じフォルダに証券コード名で保存する。

Dim SaveFN As String, DFURL As String, ReturnValue As Long, SCode As Long

    SCode = 7203 '証券コード。7203→トヨタ自動車
    SaveFN = ThisWorkbook.Path & "\" & SCode & ".jpg" '画像ファイルの保存先とファイル名を設定
    DFURL = "http://chart.yahoo.co.jp/?code=" & SCode & ".T&tm=1y&type=c&log=off&size=m&over=m65,m130,s&add=vm,ss&comp=" 'ダウンロードしたいファイルのURLを設定

    ReturnValue = URLDownloadToFile(0, DFURL, SaveFN, 0, 0) '実行部分
    
        
    If ReturnValue = 0 Then 'ダウンロードに成功すると「ReturnValue =0」となる。ただの確認
        Debug.Print "ダウンロード成功"
        Else
        Debug.Print "ダウンロード失敗"
    End If
    
End Sub

エクセルでバーコードを利用する-1

エクセル

備品の管理をエクセルで行っているような場合に、エクセルで管理番号をバーコード印刷できると便利です。

 

方法は大まかに2つあります。「1は簡便、2はバーコードの種類が多く細かな設定が可能」という利点があげられます。今回は1について書きます。

 

1.バーコードフォントを利用する。

2.Barcodecontrolを利用する。

 

 

バーコードフォントの利用手順

 

フォントをダウンロード

↓

フォントのインストール

という手順になります。インストールすると明朝体などの並びにバーコードのフォントが選べるようになり、セルのフォントをバーコードフォントに指定するだけで、セルの文字がバーコードで表示されます。

以下のサイトで3種類のフォントがダウンロードできます。

www.technical.jp

選択したフォントによっては前後に特定の文字を付ける必要があります。

 

参考

フォントのインストール方法（Windows 7 の場合）

 ＊アドミン権限が必要でした。

 

www.keyence.co.jp

【必携Function-1】【エクセル2013,VBA】

エクセル VBA

新しくエクセルのアプリケーションを作る際には、便利なFunctionの一群をまずはごっそり移すところからはじめます。

以下、必携のファンクションを紹介します。

1.GetDeskTopPath
デスクトップのパスを取得するファンクション。例えば↓のような使い方をします。
デスクトップのパスをデフォルトの保存場所などにしておくと、不特定のPCでも動作するファイルになります。

Thisworkbook.pathも同じような目的で使用します。また「("Desktop")」を変更すればマイドキュメント等のパスの取得も可能です。

2.GetUserName,GetComputerName
user nameやコンピュターnameを取得するファンクション。例えば↓のような使い方をします。
社用PCなどuser nameと利用者情報の対応表が存在する場合、このファンクションを利用して利用者情報の自動入力補助ができるようになります。

3.SelectFold,SelectFile
ダイヤログボックスからフォルダやファイルを指定（＝パスを取得）できます。
動的なアプリケーションに必須です。

動的にしておくと、様々なデータやファイルで検証しやすいのでテストの際などにも便利です。

Sub 動作確認()

MsgBox "Functionの動作確認 "
MsgBox GetDeskTopPath
MsgBox GetUserName
MsgBox GetComputerName
MsgBox SelectFold
MsgBox SelectFile

End Sub

Function GetDeskTopPath()
    'デスクトップパス取得
    Dim MyWSH  As Object
    Set MyWSH = CreateObject("WScript.Shell")
    
    GetDeskTopPath = MyWSH.SpecialFolders("Desktop")
    
    Set MyWSH = Nothing
End Function

Function GetUserName()
    'ユーザーネーム取得
    Dim WshNetworkObject As Object
    Set WshNetworkObject = CreateObject("WScript.Network")
      
    GetUserName = WshNetworkObject.UserName

    Set WshNetworkObject = Nothing
    
End Function

Function GetComputerName()
    'コンピューターネーム取得
    Dim WshNetworkObject As Object
    Set WshNetworkObject = CreateObject("WScript.Network")
      
    GetComputerName = WshNetworkObject.ComputerName

    Set WshNetworkObject = Nothing
    
End Function

Function SelectFold() As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダー選択"
        If .Show = -1 Then
            SelectFold = .SelectedItems(1)
        Else                'キャンセルボタンがクリックされた
            SelectFold = "CANCEL"
        End If
End With

End Function

Function SelectFile() As String

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "ファイル選択"
        If .Show = -1 Then
            SelectFile = .SelectedItems(1)
        Else                'キャンセルボタンがクリックされた
            SelectFile = "CANCEL"
        End If
End With

End Function

【2つのシートの内容を比較】【エクセル2013,VBA】

エクセル VBA

複数人で同一ファイルに書き込みをするような作業の際に、作業前のシートと作業後のシートを比較し、どこが修正されたかを確認したくなる場合があります。中には適当なひとやエクセルが苦手なひともいたりするため、気がつかずに違うセルの内容を消したり上書きしたり等のミスが生じることがあります。

 

比較の対象は「値と数式」です。数式は見た目にはわからなくとも、セルの削除などでおかしなことになるときがあります。書式も比較できるようにしたかったのですが、長くなるので断念しました。

 

内容

Step0.比較したい2つのシートは同一ブック内にあることが前提。

Step1.比較したい1枚目のシートの比較したい範囲を指定する。

Step2.比較したい2枚目のシートの名前を入力する。

Step3,4.比較作業が行われる。結果は追加されたシートに出力される。（青塗りだと変化なし。赤塗りだと値または数式が異なる。表示されている値は比較シート1の値。）

 

f:id:DuKicco:20150531085136j:plain

以下コード

=========================================================

Sub シート比較()

Dim SN1 As String, SN2 As String, SN As String, buf As Range, TCell As Range

'Step1:比較したいシート(1枚目）の比較したい範囲を選択
Set buf = Application.InputBox(prompt:="比較したいシート(1枚目）の範囲を選択してください）", Type:=8)
SN1 = buf.Parent.Name

 

'Step2:比較したいシート(2枚目）の名前を入力。デフォルト値は2枚目のシート
SN2 = InputBox("比較したいシート(2枚目）の名前を入力", "", Sheets(2).Name)

 

'Step3:比結果の記入用シートの追加
Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
SN = ActiveSheet.Name


'Step4:指定した各セル内容を比較していき、結果シートに記入する。
For Each TCell In buf
'結果シートの対応するセルに比較シート1の数式なければ値を記入していく（書式は関係なし）
Sheets(SN).Range(TCell.Address).Formula = TCell.Formula
'比較シート1と2の数式なければ値を比較し異なる場合には結果シートの対応するセルを赤塗りにしていく。同一であれば青塗り。
If TCell.Formula <> Sheets(SN2).Range(TCell.Address).Formula Then
Sheets(SN).Range(TCell.Address).Interior.Color = 255
Else
Sheets(SN).Range(TCell.Address).Interior.Color = 15773696
End If

Next

End Sub

【複数ブック、アンケート、集計】【エクセル2013,VBA】

エクセル VBA

アンケートをエクセルで作成し、とりまとめ集計するためののコード。

なるべく汎用的に利用できるように、集計範囲をダイアログボックスで指定できるようにしています。

 

f:id:DuKicco:20150530094924j:plain

前提としては

・集計するブックの構成（回答の場所）は全て同じアドレスのセル

・アンケート結果は各ブックの1枚目のシートに記載する

・アンケートのブックは複数指定可

 

==================================

Sub アンケート集計()

Dim i As Long, j As Long, k As Long, GyoN As Long, tst As String, CellA As String, SN As String
Dim buf As Range, TCell As Range, arr1() As String


Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
SN = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name


'Step1:集計するセルの指定を行う
With Application.FileDialog(msoFileDialogOpen)
.Title = "まずは集計するセルを指定します。" & Chr(13) & "どれでもよいので集計したいファイルをひとつ開いてください。"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = False
.Show

Workbooks.Open Filename:=.SelectedItems(1)
tst = ActiveWorkbook.Name
Set buf = Application.InputBox(prompt:="集計したいセルを選択してください（+ctrで複数選択可）", Type:=8)

ReDim arr1(1 To buf.Cells.Count) As String

i = 1
'セルのアドレスを配列に格納と同時にアドレスを記録
For Each TCell In buf
arr1(i) = TCell.Address
ThisWorkbook.Sheets(SN).Cells(1, i) = arr1(i)

i = i + 1
Next


Workbooks(tst).Close SaveChanges:=False

End With


'Step2:集計
GyoN = 2
With Application.FileDialog(msoFileDialogOpen)
.Title = "集計したいファイルを選択してください（+ctrで複数選択可）"

'複数指定可

.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show


'順番にファイルを開き、step1で指定したセルをシートに書き出していく
For i = 1 To .SelectedItems.Count

Workbooks.Open Filename:=.SelectedItems(i)
tst = ActiveWorkbook.Name

For k = 1 To UBound(arr1)
'シートは一枚目のみ利用する。2枚目以降は無視される。

’追加したシートに書き出し
ThisWorkbook.Sheets(SN).Cells(GyoN, k) = Workbooks(tst).Sheets(1).Range(arr1(k))

Next

GyoN = GyoN + 1
Workbooks(tst).Close SaveChanges:=False
Next

End With

End Sub

【複数のブックをひとつのブックにまとめる】【エクセル2013,VBA】

エクセル VBA

複数のブックをまとめるコード。例えばエクセルで作成した雛形やアンケートをメールで配り記入してもらい、その回答をひとつのブックにまとめたい場合に使用する。

 

以下コード

==============================================================

Sub シート集計()
Dim i As Long, tst As String, CellA As String

'シート内の特定のセルをシート名にしたい場合はCellAにアドレスを入れる。例：各シートのRange("A1")に名前や固有のIDが入っていてそれをシート名にしたい場合「CellA="A1"」とする。
CellA = ""

With Application.FileDialog(msoFileDialogOpen)
.Title = "統合したいエクセルファイルを選択（+ctr or +shiftで複数選択）"
.Filters.Add "Excelブック", "*.xls; *.xlsx; *.xlsm", 1
.InitialFileName = ThisWorkbook.Path
.AllowMultiSelect = True
.Show

For i = 1 To .SelectedItems.Count

'フルパスからファイル名を取得する。
tst = Dir(.SelectedItems(i))
'選んだブックを順に開く
Workbooks.Open Filename:=.SelectedItems(i)
'シートは「すべて」コピーされる。
Sheets.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'CellAが空欄でなければシート名を書き換える
If CellA <> "" Then
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Range(CellA)
End If

'ブックを閉じる。
Workbooks(tst).Close SaveChanges:=False

Next
End With

End Sub


Sub 特定シートの削除()
'おまけ。特定の名前のついているシートを削除する。
Dim SN As String, SC As Long
Application.DisplayAlerts = False
'↓の場合はSheetという文字が含まれるシートを削除
SN = "Sheet"
SC = Sheets.Count
For i = SC To 1 Step -1
If InStr(1, Sheets(i).Name, SN) > 0 Then
Sheets(i).Delete
End If
Next
Application.DisplayAlerts = True
End Sub


Sub シート削除All()
'Sheets(1)を除くすべてのシートを削除する。
On Error Resume Next
Dim SN As String, SC As Long
Application.DisplayAlerts = False
SC = Sheets.Count
For i = SC To 1 Step -1
Sheets(i).Delete
Next
Application.DisplayAlerts = True
End Sub