カテゴリー: Windows

Excelでオブジェクトを変数宣言するには
遅延バインディングと事前バインディングの2種類の方法がある。

実装の違い(例として、FileSystemObjectを利用)

• 遅延バインディング

Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")

• 事前バインディング

「ツール」→「参照設定」で
「Microsoft Scripting Runtime」にチェックを付ける。

Dim objFSO As New FileSystemObject
または、
Dim objFSO As FileSystemObject
Set objFSO = New FileSystemObject

一言で言えば、変数宣言の型が
遅延バインディングはObject型
事前バインディングは特定のオブジェクト型
となっている。

遅延バインディング（実行時バインディング）

オブジェクトが Object 型として宣言された変数に代入する場合、
遅延（実行時）にバインディングされる。
この型のオブジェクトは、任意のオブジェクトへの参照を保持できるが、
事前バインディングされたオブジェクトの利点をほとんど持たない。

事前バインディング

特定のオブジェクト型として宣言された変数に代入する場合、
オブジェクトは事前（コンパイル時に）バインディングされる。
事前バインディングされたオブジェクトでは、アプリケーションが実行される前に、
コンパイラによってメモリの割り当てとその他の最適化が実行される。
また、自動クイックヒントが表示されるようになる。

名前の定義は有能だと思うのですが、
参考ブックからコピーすると一緒にコピーされ、
収集つかなくなるためこれで削除します。

Option Explicit

Private Sub NameDefDel()
    Dim Ans, RefStyle, n
    
    Ans = MsgBox("実行しますか？", vbYesNo, "実行確認")
    If Ans = vbNo Then Exit Sub
    
    RefStyle = Application.ReferenceStyle
    
    If RefStyle = xlR1C1 Then
        Application.ReferenceStyle = xlA1
    Else
        Application.ReferenceStyle = xlR1C1
    End If

    For Each n In ActiveWorkbook.Names
        If Not n.Name Like "*!Print_Area" And _
            Not n.Name Like "*!Print_Titles" Then
            n.Delete
        End If
    Next

    Application.ReferenceStyle = RefStyle
    
    MsgBox "完了しました！"
End Sub

選択範囲の取消線を削除します。
納品時の作業で利用することあり。

Sub StrikethroughDel()
    For Each myCell In Selection
        textBefore = myCell.Value
        textAfter = ""
        For i = 1 To Len(textBefore)
            If myCell.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
                textAfter = textAfter & Mid(textBefore, i, 1)
            End If
        Next i
    Next myCell
End Sub

フォルダ内のJPGファイルをフォルダごとのシートを作成し、
そのシート内に自動で貼り付けします。

Sub JpgPut()

' JpgPut
' JPGファイルを貼り付ける。
' エビデンスが存在する1階層上のフォルダを指定する。(末尾\)
' フォルダ内のJPGファイルは100枚まで。
' 例)
' C:\work\ebi\を指定した場合、
' C:\work\ebi\imgフォルダ内のJPGファイルを貼り付ける。

    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "処理中・・・"
    
    Dim count As Integer
    count = 0
    Dim folderPath As String ' 環境によって変更すること。
    folderPath = Worksheets(1).Cells(2, 1).Value
    
    Dim fileName As String
    fileName = Dir(folderPath & "\", vbDirectory)
    
    Dim n As Integer
    n = 0
    
    Dim fileNames(100) As String
    Do While fileName <> ""
        fileNames(n) = fileName
        n = n + 1
        fileName = Dir()
    Loop
    
    Dim i As Integer
    Dim j As Integer
    For j = 0 To n
        fileName = fileNames(j)
        If GetAttr(folderPath & "\" & fileName) And vbDirectory Then
            If fileName <> "." And fileName <> ".." And fileName <> "" Then
                i = 0
                Dim newSheet As Worksheet
                Set newSheet = Worksheets.Add()
                newSheet.Move after:=Worksheets(Worksheets.count)
                newSheet.Name = fileName
                
                Dim jpgPath As String
                jpgPath = Dir(folderPath & "\" & fileName & "\" & "*.JPG", vbNormal)
                Do While jpgPath <> ""
                
                    ' 画像の高さに合わせて「45」の数値を変更すること。
                    newSheet.Cells(i * 45 + 1, 1).Value = jpgPath
                    newSheet.Cells(i * 45 + 2, 2).Select
                    
                    ' Excel2010の場合はここから
                    ' 画像を1*1ポイントで貼り付け
                    Set myShape = Worksheets(fileName).Shapes.AddPicture( _
                    fileName:=folderPath & "\" & fileName & "\" & jpgPath, _
                    linkToFile:=False, _
                    saveWithdocument:=True, _
                    Left:=Selection.Left, _
                    Top:=Selection.Top, _
                    Width:=msoTrue, _
                    Height:=msoTrue)
                    ' 画像を元のサイズに変換(Heightの設定は不要かも)
                    ' Withを利用しないとオブジェクトエラーになる。
                    With myShape
                        LockAspecRatio = msoTrue
                        Hieght = 560
                    End With
                    'myShape.LockAspecRatio = msoTrue
                    'myShape.Hieght = 560
                    ' Excel2010の場合はここまで
                    
                    ' Excel2013の場合はここから
                    'Worksheets(fileName).Picutures.Insert fileName:=folderPath & "\" & fileName & "\" & jpgPath
                    ' Excel2013の場合はここまで
                    
                    i = i + 1
                    count = count + 1
                    jpgPath = Dir()
                Loop
                
            End If
        End If
    Next j
    
    Application.StatusBar = count & "個貼り付け完了"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub