ExcelVBAメモ

## 動作環境
Excel2016 64bitで確認

### シート目次作成マクロ
シートが増えてくると目次があれば便利です。
シートの一覧とリンクを自動作成します

```
Sub ListSheetsName()

    Dim objSheet As Object
    Dim i, arow, acolumn
  
    Cells(1, 1).Select
    i = 1   'No記載用
    
    arow = 6    '貼り付け開始行数
    acolumn = 2   '貼り付け開始列

    For Each objSheet In ActiveWorkbook.Sheets
        
        'NO記載
        Cells(arow, acolumn) = i
        'リンク作成
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(arow, acolumn + 1), Address:="", SubAddress:="'" & objSheet.Name & "'!a1", TextToDisplay:=objSheet.Name

        arow = arow + 1
        i = i + 1
    Next

End Sub
```

### 指定フォルダのファイル一覧を取得

```
Sub ファイル名取得()
  Dim BUF As String
  Dim i As Integer 'カウンタ
  Dim i2 As Integer '書き込み行カウンタ
  Dim mypas
  
  mypas = Cells(1, 2)
  MsgBox mypas
  BUF = Dir(mypas & "\*", vbDirectory)
  
  i = 1
  i2 = 4
  
  Do While BUF <> ""
    If BUF <> "." And BUF <> ".." Then
        Worksheets("Sheet1").Cells(i2, 1) = i
        Worksheets("Sheet1").Cells(i2, 2) = BUF
        i = i + 1
        i2 = i2 + 1
    End If
    BUF = Dir()
  Loop

End Sub
```

### 指定フォルダ配下のファイル一覧を再帰的に取得する
ファイルのリストを作成するときに

```
 Sub 実行()
    
    Call setFileList(Cells(3, 2))   'フォルダパスを入力するセル

End Sub


Sub setFileList(searchPath)
    Dim startCell As Range
    Dim maxRow As Long
    Dim maxCol As Long

    Set startCell = Cells(6, 2) 'このセルから出力し始める
    startCell.Select
    
    'シートをいったんクリア
    maxRow = startCell.SpecialCells(xlLastCell).Row
    maxCol = startCell.SpecialCells(xlLastCell).Column
    Range(startCell, Cells(maxRow, maxCol)).ClearContents
    
    Call getFileList(searchPath)
    startCell.Select
End Sub

Sub getFileList(searchPath)
'Microsoft Scripting Runtime参照

    Dim FSO As New FileSystemObject
    Dim objFiles As File
    Dim objFolders As Folder
    Dim separateNum As Long

    'サブフォルダ取得
    For Each objFolders In FSO.GetFolder(searchPath).SubFolders
        Call getFileList(objFolders.Path)
    Next
    
    'ファイル名の取得
    For Each objFiles In FSO.GetFolder(searchPath).Files
        separateNum = InStrRev(objFiles.Path, "\")
        'セルにパスとファイル名を書き込む
        'パス
        ActiveCell.Value = Left(objFiles.Path, separateNum - 1)
        'ファイル名
        ActiveCell.Offset(0, 1).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
        '更新日時
        ActiveCell.Offset(0, 2).Value = FileDateTime(objFiles)
        'サイズ
        ActiveCell.Offset(0, 3).Value = Format((FileLen(objFiles) / 1024), "#.0")
        '拡張子
        ActiveCell.Offset(0, 4).Value = FSO.GetExtensionName(objFiles.Path)
        
        '次のセルを選択する
        ActiveCell.Offset(1, 0).Select
    
End Sub

```

## ほか

### BIOS情報

```
Sub BIOS取得()

Dim BiosSet As SWbemObjectSet
Dim Bios As SWbemObject
Dim Locator As SWbemLocator
Dim Service As SWbemServices
Dim MesStr As String

Set Locator = New WbemScripting.SWbemLocator
Set Service = Locator.ConnectServer

Set BiosSet = Service.ExecQuery("Select * From Win32_BIOS")

For Each Bios In BiosSet

MesStr = "BIOSの種類：" + Bios.Description + vbCrLf + _
        "BIOSの製造元：" + Bios.Manufacturer + vbCrLf + _
        "BIOSのシリアルナンバー：" + Bios.SerialNumber + vbCrLf + _
        "BIOSのバージョン：" + Bios.SMBIOSBIOSVersion


Next

'"機種：" + Bios.Model + vbCrLf + _

MsgBox "BIOSの色々な情報です。" + _
            vbCrLf + MesStr + vbCrLf + "です。"

Set BiosSet = Nothing
Set Bios = Nothing
Set Locator = Nothing
Set Service = Nothing

End Sub

```

### マザーボード情報取得

```
Sub マザーボード取得()

Dim BaseSet As SWbemObjectSet
Dim Base As SWbemObject
Dim Locator As SWbemLocator
Dim Service As SWbemServices
Dim MesStr As String

Set Locator = New WbemScripting.SWbemLocator
Set Service = Locator.ConnectServer

Set BaseSet = Service.ExecQuery("Select * From Win32_BaseBoard")

For Each Base In BaseSet

MesStr = "マザーボードの製造元：" + Base.Manufacturer + vbCrLf + _
        "マザーボードの製品名：" + Base.Product + vbCrLf + _
        "マザーボードのバージョン：" + Base.Version

Next

MsgBox "マザーボードの色々な情報です。" + _
            vbCrLf + MesStr + vbCrLf + "です。"

Set BaseSet = Nothing
Set Base = Nothing
Set Locator = Nothing
Set Service = Nothing

End Sub
```

### インターネットからファイルをダウンロードする
特定サイトからファイルをダウンロードしたい場合に

```
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
 
Private Declare PtrSafe Function DeleteUrlCacheEntry _
    Lib "wininet" Alias "DeleteUrlCacheEntryA" _
    (ByVal lpszUrlName As String) As Long
 
Private Declare PtrSafe Sub Sleep _
    Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub Main()
' 概　要：インターネットからファイルをダウンロードする
 
    Dim strUrl As String    'ダウンロード対象のURL
    Dim strFilePath As String   '保存先パス
    
    'ダウンロード先URL　以下は構成調査のCSVの例
    strUrl = "https://www.e-stat.go.jp/stat-search/file-download?statInfId=000031524010&fileKind=1"
  
    ' ダウンロードしたファイルの保存先
    strFilePath = ThisWorkbook.Path & "\SaveFile.csv"
    
    If Download(strUrl, strFilePath) Then
        MsgBox "ダウンロードが完了しました", vbInformation, "ダウンロードの完了"
    Else
        MsgBox "ダウンロードに失敗しました", vbCritical, "ダウンロードの失敗"
    End If
    
End Sub
' ----------------------------------------------------------
' 引　数：lngWaitMs     待機するミリ秒
' 戻り値：True：成功    False：失敗
' ----------------------------------------------------------
Private Function Download(ByVal strUrl As String, _
                            ByVal strFilePath As String, _
                            Optional ByVal lngWaitMs As Long = 5000) As Boolean
    Dim lngResult As Long
    
    ' キャッシュのクリア
    DeleteUrlCacheEntry (strUrl)
    
    ' ファイルのダウンロード
    lngResult = URLDownloadToFile(0, strUrl, strFilePath, 0, 0)
    
    ' ダウンロードできたかどうかを戻り値へ
    Download = (lngResult = 0)
    
    ' 待機
    Sleep (lngWaitMs)
    
End Function
 ```

##履歴
2021/10/28 作成
2021/11/11 ダウンロードマクロを追加、その他微修正