Outlookの練習

Option Explicit

Sub SendBasicEmailEarlyBinding()
‘Microsoft Outlook 16.0 libraryを early bindingする
‘Outlookは、このようにdimするしかない。理由はここでは省略
Dim olApp As Outlook.Application

    Set olApp = New Outlook.Application

End Sub

Sub SendBasicEmailLateBinding()
‘Microsoft Outlook 16.0 libraryを Late bindingする
‘Outlookは、このようにdimするしかない。理由はここでは省略
Dim olApp As Object

    Set olApp = CreateObject("Outlook.Application")

End Sub

Sub SendBasicEmail()
‘Microsoft Outlook 16.0 libraryを early bindingする
‘Outlookは、このようにdimするしかない。理由はここでは省略

    'このあたりのdimやsetはもう丸覚えしかない
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem

    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    olEmail.Display
    'これで、outlookを起動して、ブランクのemailウィンドゥが開かれる

End Sub

Sub SendBasicEmail2()
‘Microsoft Outlook 16.0 libraryを early bindingする
‘Outlookは、このようにdimするしかない。理由はここでは省略

    'このあたりのdimやsetはもう丸覚えしかない
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem

    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    With olEmail
                    .BodyFormat = olFormatHTML
                    .Display
            .HTMLBody = "<H1>Dear Someone</H1>"
            'displayしてもしなくてもよい

‘ .Display
.To = “akijsaito@mac.com”
.Subject = “Movie Report”

‘ .BodyFormat = olFormatPlain
‘ .BodyFormat = olFormatRichText
‘ .Body = “Dear someone”
‘HTMLbodyでは、タグが書ける
‘.Sendで一気に送信
.Send

    End With

End Sub

Sub SendBasicEmail_Attachement()
‘Microsoft Outlook 16.0 libraryを early bindingする
‘Outlookは、このようにdimするしかない。理由はここでは省略

    'このあたりのdimやsetはもう丸覚えしかない
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem

    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    With olEmail
                    .BodyFormat = olFormatHTML
                    .Display
            .HTMLBody = "<H1>Dear Someone</H1>"

‘ .Attachments.Add “c:\users\akishige saito\documents\book1.xlsm”
‘Environ(“UserProfile”) で、”c:\users\akishige saito”を得ることができる
.Attachments.Add Environ(“UserProfile”) & “\documents\book1.xlsm”
‘displayしてもしなくてもよい
‘ .Display
.To = “akijsaito@mac.com”
.Subject = “Movie Report”

‘ .BodyFormat = olFormatPlain
‘ .BodyFormat = olFormatRichText
‘ .Body = “Dear someone”
‘HTMLbodyでは、タグが書ける
‘.Sendで一気に送信
‘ .Send

    End With

End Sub

Sub SendBasicEmail_Attachement_LateBinding()
‘Microsoft Outlook 16.0 libraryを late bindingする
‘Microsoft Outlook 16.0 libraryのlate bindingは、なかなか面倒なことが多い
‘Outlookは、このようにdimするしかない。理由はここでは省略

    'このあたりのdimやsetはもう丸覚えしかない
    Dim olApp As Object
    Dim olEmail As Object

    Set olApp = CreateObject("Outlook.Application")
    Set olEmail = olApp.CreateItem(0)

    With olEmail
                    .BodyFormat = 2
                    .Display
            .HTMLBody = "<H1>Dear Someone</H1>"

‘ .Attachments.Add “c:\users\akishige saito\documents\book1.xlsm”
‘Environ(“UserProfile”) で、”c:\users\akishige saito”を得ることができる
.Attachments.Add Environ(“UserProfile”) & “\documents\book1.xlsm”
‘displayしてもしなくてもよい
‘ .Display
.To = “akijsaito@mac.com”
.Subject = “Movie Report”

‘ .BodyFormat = olFormatPlain
‘ .BodyFormat = olFormatRichText
‘ .Body = “Dear someone”
‘HTMLbodyでは、タグが書ける
‘.Sendで一気に送信
‘ .Send

    End With

End Sub

Sub SendComplexEmail()
‘Microsoft Outlook 16.0 libraryを early bindingする
‘Outlookは、このようにdimするしかない。理由はここでは省略

    'このあたりのdimやsetはもう丸覚えしかない
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem

    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    With olEmail
            .BodyFormat = olFormatPlain
            .Display

            .Body = "Dear Someone" & vbNewLine & vbNewLine & GetMovieData & .Body

            .To = "akijsaito@mac.com"
            .Subject = "Movie Report"
    End With

End Sub

Function GetMovieData() As String
‘これは面白い。どこかで役に立つ

    Dim FilmColumn As Range, FilmRow As Range, r As Range, c As Range
    Dim str As String

    Sheet1.Activate
    Set FilmRow = Range("A2", Range("A1").End(xlDown))

    For Each r In FilmRow   '全部の行をスイープする
            Set FilmColumn = Range(r, r.End(xlToRight))
                    For Each c In FilmColumn        '全部のカラムをスイープする
                            str = str & c.Value

                            '最後のカラムのあとにvbtabを入れないようにするため
                            If c.Column < r.End(xlToRight).Column Then
                                    str = str & vbTab
                            End If

                    Next c

                    '最後の行のあとにvbnewlineを入れないようにするため
                    If r.Row < Range("A1").End(xlDown).Row Then
                            str = str & vbNewLine
                    End If
    Next r

    GetMovieData = str

End Function

GetOpenFileNameの練習-1

Option Explicit

Sub Consolidate()

Dim FileNameList As Variant
Dim i As Long
Dim FileName As String

Dim SourceFileName As String

FileNameList = Application.GetOpenFilename(“Microsoft Excelブック, *.xlsx”, MultiSelect:=True)

If IsArray(FileNameList) Then
    For i = 1 To UBound(FileNameList)

    Debug.Print FileNameList(i)

    FileName = FileNameList(i)

    Debug.Print Dir(FileName)

   Workbooks.Open SourceFileName
    Next i

Else
    MsgBox "Cancelled"
End If

End Sub

ADOの練習-1

Option Explicit

‘Connection StringはCONSTで書いておくと便利
Const ConStrAccess As String = “Provider=Microsoft.ACE.OLEDB.12.0; ” & _
“Data Source=C:\Users\Akishige Saito\Documents\VeryLargeDatabase.accdb;” & _
“Persist Security Info=False;”

Const ConStrSQL As String = “Provider=SQLNCLI11;” & _
“Server=SURFACELAPTOPBU;” & _
“Database=myDataBase;” & _
“Trusted_Connection=yes;”

Sub CopyDataFromAccessDatabase()
Dim MoviesConn As ADODB.Connection
Dim MoviesData As ADODB.Recordset
‘ADODB.fieldは、テーブルの列名を得る方法
Dim MoviesField As ADODB.Field

    Set MoviesConn = New ADODB.Connection
    Set MoviesData = New ADODB.Recordset

    'connectionstrings.comを参考にしよう
    MoviesConn.ConnectionString = ConStrAccess
    MoviesConn.Open

    On Error GoTo CloseConnection

    With MoviesData
            .ActiveConnection = MoviesConn
            '.sourceにSQLを書く
            .Source = "SELECT tblMovie.director_name FROM tblMovie WHERE (((tblMovie.director_name) Like 'a%'));"
            .LockType = adLockReadOnly
            .CursorType = adOpenForwardOnly
            .Open
    End With

    On Error GoTo CloseRecordset

    Worksheets.Add

    'ADODB.fieldを、シートの1行目にセットするループです
    For Each MoviesField In MoviesData.Fields
            ActiveCell.Value = MoviesField.Name
            ActiveCell.Offset(0, 1).Select
    Next MoviesField

    Range("A1").Select

    'CopyFromRecordsetで、簡単に全レコードを持ってこれる
    Range("A2").CopyFromRecordset MoviesData
    'シートをオートフィットさせる
    Range("A2").CurrentRegion.EntireColumn.AutoFit

    On Error GoTo 0

CloseRecordset:
MoviesData.Close

CloseConnection:
MoviesConn.Close

End Sub

Sub CopyDataFromSQLServer_Database()
Dim MoviesConn As ADODB.Connection
Set MoviesConn = New ADODB.Connection

    'connectionstrings.comを参考にしよう
    MoviesConn.ConnectionString = ConStrSQL

    MoviesConn.Open

    MoviesConn.Close

End Sub