④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載
Sub CreateEmail()
Dim oApp As Object
Dim objMAIL As Object
Dim messageList(1) As String
Dim n As Long
Dim fullName As String
Dim firstName As String
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
oApp.GetNamespace("MAPI").GetDefaultFolder(6).display
End If
fullName = Application.UserName
firstName = Mid(fullName, 1, InStr(fullName, " ") - 1)
Set objMAIL = oApp.CreateItem(0)
'メールに載せるメッセージ本文'
messageList(0) = "お疲れ様です。" & firstName & "です。" & vbCrLf & vbCrLf & _
"共有ファイルNo." & Cells(3, 3).Value & "に追記を行いました。" & vbCrLf & _
"タイミングを見てご確認ください。" & vbCrLf & vbCrLf & _
"<\ShareServer\メールを自動作成する.xlsm>" &amp; vbCrLf
messageList(1) = vbCrLf &amp; " 以上、宜しくお願い致します。"
Dim adress As String
Dim i As Long
For i = 1 To 50
adress = adress + ThisWorkbook.Worksheets("宛先").Cells(i + 1, 2).Value
adress = adress + " ;"
Next i
objMAIL.To = adress
'件名'
objMAIL.Subject = "共有ファイルNo." &amp; Cells(3, 3).Value &amp; "を追加しました"
objMAIL.BodyFormat = 2 'HTML形式
objMAIL.Body = messageList(0) &amp; messageList(1)
objMAIL.display
n = Len(messageList(0))
ActiveSheet.Range(Cells(Cells(3, 3) + 5, 2), Cells(Cells(3, 3) + 5, 5)).Copy
oApp.ActiveInspector.WordEditor.Range(n, n).Paste
Application.CutCopyMode = False
Set objMAIL = Nothing
Set oApp = Nothing
End Sub
④Microsoft Visual Basic for Applications」にて以下のコードを記載
Sub CreateQrcode()
'開始行
Dim firstRow As Long: firstRow = 3
'最終行の取得
Dim lastRow As Long: lastRow = Cells(Rows.Count, 1).End(xlUp).Row
'firstRow～lastRowまで繰り返し(途中エラーが出た場合も止めずに最後まで処理)
On Error Resume Next
For i = firstRow To lastRow
'QRコード表示セルの高さなどを調整
With Cells(i, "B")
.RowHeight = 65
.VerticalAlignment = xlTop '上詰め
End With
'GoogleAPIでQRコードを作成
Set qr = ActiveSheet.Pictures _
.Insert("http://chart.apis.google.com/chart?cht=qr&amp;amp;amp;amp;chs=80x80&amp;amp;amp;amp;chl=" _
+ Cells(i, "A").Value)
'QRコードの表示位置を指定
With qr
.Top = Cells(i, "B").Top + 2
.Left = Cells(i, "B").Left + 2
End With
Next i
On Error GoTo 0
End Sub
④ 「Microsoft Visual Basic for Applications」にて以下のコードを記載
Sub ConvertTable()
Dim result As String
Dim startRow, startCol, endRow, endCol As Integer
Dim selectArea As Range
Set selectArea = Selection
startRow = selectArea.Cells(1).Row
startCol = selectArea.Cells(1).Column
endRow = selectArea.Cells(selectArea.Count).Row
endCol = selectArea.Cells(selectArea.Count).Column
Dim widthDic As Object
Set widthDic = CreateObject("Scripting.Dictionary")
Dim maxWidth As Integer: maxWidth = 0
Dim cellVal As String
Dim margin As Integer
' 各列毎の最大幅を配列で保持
For j = startCol To endCol Step 1
For i = startRow To endRow Step 1
cellVal = Cells(i, j).Value
If IsNumeric(cellVal) And Cells(i, j).NumberFormatLocal = "#,##0" Then
cellVal = Format(cellVal, "#,#")
End If
If maxWidth < LenB(StrConv(cellVal, vbFromUnicode)) Then
maxWidth = LenB(StrConv(cellVal, vbFromUnicode))
End If
Next
widthDic.Add j, maxWidth
maxWidth = 0
Next
' 表文字列の作成
For i = startRow To endRow Step 1
' 線だけの行を書き込み
For j = startCol To endCol Step 1
If i = startRow Then
If j = startCol Then
result = result & "┌"
Else
result = result & "┬"
End If
Else
If j = startCol Then
result = result & "├"
Else
result = result & "┼"
End If
End If
result = result & String(Application.WorksheetFunction.RoundUp(widthDic.Item(j) / 2, 0), "─")
If i = startRow And j = endCol Then
result = result & "┐"
ElseIf i <> startRow And j = endCol Then
result = result & "┤"
End If
Next
result = result & vbCrLf
' 値の行を書き込み
For j = startCol To endCol Step 1
result = result & "│"
cellVal = Cells(i, j).Value
If IsNumeric(cellVal) And Cells(i, j).NumberFormatLocal = "#,##0" Then
cellVal = Format(cellVal, "#,#")
End If
margin = widthDic.Item(j) - LenB(StrConv(cellVal, vbFromUnicode))
margin = margin + widthDic.Item(j) Mod 2
If IsNumeric(cellVal) Then
result = result & Space(margin)
result = result & cellVal
Else
result = result & cellVal
result = result & Space(margin)
End If
If j = endCol Then
result = result & "│"
End If
Next
result = result & vbCrLf
Next
' 最下部の線を書き込み
For j = startCol To endCol Step 1
If j = startCol Then
result = result & "└"
Else
result = result & "┴"
End If
result = result & String(Application.WorksheetFunction.RoundUp(widthDic.Item(j) / 2, 0), "─")
If j = endCol Then
result = result & "┘"
End If
Next
'表文字列をクリップボードに格納する
With New MSForms.DataObject
.SetText result
.PutInClipboard
End With
End Sub
