GDIplusCODE


'縮小率設定を求める
Private Sub setScale()
    Dim buf As Double
    
    buf = Application.InputBox(Prompt:="縮小倍率％を入力して下さい。", Type:=1)
    If buf <= 0 Then
      MsgBox "99～1の数値を入力して下さい"
      Exit Sub
    End If
    ThisWorkbook.Sheets(1).Range("A1").Value = buf
End Sub

'サムネイル作成＆ハイパーリンク設定
Private Sub pasteThumbnail()
  Dim FSO As Object
  Dim fileList As Object
  Dim myfile As Object
  Dim i As Long, j As Long
  Dim targetFolder As String
  Dim tempSheet As Worksheet, currentSheet As Worksheet
  Dim myRatio As Double
  
  'Activesheetが空か判別
  If ActiveSheet.UsedRange.Cells.Count > 1 Then Exit Sub
  If Not IsEmpty(ActiveSheet.Range("A1")) Then Exit Sub
  On Error Resume Next
  targetFolder = myGetFolder
    If Err.Number <> 0 Then
    MsgBox "Error " & CStr(Err.Number) & ":" & Err.Description
    Exit Sub
  End If
  On Error GoTo 0
  If targetFolder = "" Then
    MsgBox "フォルダーを指定してください"
    Exit Sub
  End If
  With ThisWorkbook.Sheets(1).Range("A1")
    If (.Value = "") Or (.Value <= 0) Then Call setScale
    myRatio = .Value / 100
  End With
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set currentSheet = ActiveSheet
  Set FSO = CreateObject("Scripting.FileSystemObject")
  With FSO.GetFolder(targetFolder)
    Set fileList = .Files
  End With
  i = 1: j = 1
  Set tempSheet = currentSheet.Parent.Sheets.Add
  For Each myfile In fileList
    If UCase(FSO.GetExtensionName(myfile.Path)) = "JPG" Then
      tempSheet.Activate
      tempSheet.Pictures.Insert(myfile.Path).Select
      Selection.ShapeRange.LockAspectRatio = msoTrue
      'このへんのサイズ、縮小率はお好みで
'      If Selection.ShapeRange.Height > Selection.ShapeRange.Width Then
'        Selection.ShapeRange.Height = 40
'        Selection.ShapeRange.Width = 30
'      Else
'        Selection.ShapeRange.Height = 30
'        Selection.ShapeRange.Width = 40
'      End If
       Selection.ShapeRange.ScaleWidth myRatio, msoFalse, msoScaleFromTopLeft
       Selection.ShapeRange.ScaleHeight myRatio, msoFalse, msoScaleFromTopLeft
      Selection.Copy
      currentSheet.Activate
      Cells(i + 1, j).Select
      ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
      ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=myfile.Path
      ActiveCell.Offset(-1, 0).Value = FSO.getbasename(myfile.Path)
      tempSheet.Activate
      tempSheet.Shapes(1).Delete
      i = i + 2
      If i > 20 Then
        i = 1
        j = j + 1
      End If
    End If
  Next myfile
  Set FSO = Nothing
  Application.DisplayAlerts = False
  tempSheet.Delete
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

'==================================================================================
'ダイアログを表示して、フォルダー名を取得
Private Function myGetFolder() As String

    Dim objShell  As Object 'Shell
    Dim objFolder As Object 'Shell32.Folder
    Const strTitle = "フォルダを選択してください。"

    Set objShell = CreateObject("Shell.Application")
    'フォルダー参照に設定
    Const lngRef = &H1
    'ルートフォルダーをデスクトップに設定
    '5でMy Documents、6でFavoritesなど
    Const fldRoot = &H0
    Set objFolder = _
            objShell.BrowseForFolder(0, _
                strTitle, lngRef, fldRoot)
    Set objShell = Nothing
    
    Dim strMSG
    If objFolder Is Nothing Then
        myGetFolder = ""
    Else
        If objFolder.ParentFolder Is Nothing Then
            myGetFolder = ""
        Else
            myGetFolder = objFolder.Items.Item.Path
        End If
    End If
End Function
エクセルの機能を用いてサムネイル画像を生成
