添付ファイル付きで署名入れてメールする

前回エクセル表をPDFにしました。

このPDFは、客先に送付しなきゃいけないものなんです。

これがまた面倒・・・

もう本文は定形だし、宛先も固定なんでいっそVBAでやっちまおうと。

Outlookの挙動は

jus7733.hatenablog.com

 ほぼ同じです。

ただ、署名を入れるのに若干苦労しました。

署名を

SendKeys "%N"
SendKeys "^AS"
SendKeys "{ENTER}"
で入れようとしたら、本文よりも上に署名されたのでかなり困りました。

それで検索したところ、

VBAでOutlookの署名を本文に挿入 - ClockAhead 開発Blog

こちらからご教授頂きましたぁ

で、出来たのが以下。

'//
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

 '署名のテキスト全文の読み出し

Public Function ReadAllText(fileName As String)
Dim fso As Object, buf As String
Set fso = CreateObject("Scripting.FileSystemObject")
With fso.GetFile(fileName).OpenAsTextStream(1, -2)
buf = .ReadAll
.Close
End With
Set fso = Nothing

ReadAllText = buf
End Function

Private Sub CommandButton1_Click()
Dim oApp As Object
Dim myNameSpace As Object
Dim myFolder As Object
Dim objWShell As Object
Dim flg As Boolean
Dim hwnd As Long

Const FCLASSNAME As String = "rctrl_renwnd32"

On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oApp = CreateObject("Outlook.Application")
flg = True
End If

On Error GoTo 0

If flg Then
Set myNameSpace = oApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(6)
myFolder.Display
oApp.ActiveWindow.WindowState = 2

Else
Set objWShell = CreateObject("WScript.Shell")
objWShell.AppActivate oApp.ActiveWindow.Caption
hwnd = FindWindow(FCLASSNAME, vbNullString)
SetForegroundWindow hwnd

End If

'ここからメールの作成
Dim myItem
Dim Ffldr As String
Dim Fname As String
Dim sin As String

Ffldr = "C:\Users\ユーザ名\Documents\検査成績書\PDF\"
Fname = Ffldr & Range("A11") & Format(Range("B6"), "【yymmdd】") '添付ファイルの用意

sin = ReadAllText("C:\Users\ユーザ名\AppData\Roaming\Microsoft\Signatures\署名.txt")　'署名の用意

Set myItem = oApp.CreateItem(0)

myItem.Display

myItem.Subject = "検査表を送付いたします"
myItem.To = "atesakiA@ex.com ;atesakiB@ex.com" '宛先は;で区切り
myItem.Body = "株式会社○○　御中" & vbCrLf & "" & vbCrLf & "お世話になっております｡" & vbCrLf & "検査表を送付いたします｡" & vbCrLf & vbCrLf & sin

myItem.Attachments.Add Fname & ".pdf"　'PDFを添付します

'追加動作
'myItem.Save '.Saveで保存下書きへ
'myItem.Send '.Sendで送信

End Sub

 エラー処理は全部やってないです。

しくじっても.SendはOFFしてるんで怪我しませんし(^_^;)

よくわからないこともあるけど動くからいいか！

SLAMMING HIS SEXY SEND-OFF (Taboo Forbidden Romance) (English Edition)

ExcelでPDF作成

エクセルでPDFは普通に作成できます。

ファイルーエクスポートでPDF/XPSの作成ボタンを押すだけ。

でも好きなようにファイル名を付けようとすると一々名前を打ち込まないといけない。

面倒だ・・・・

なので、以下。

検査表をエクセルで作ってPDF化するのですが、セルA11に検査対象品名セルB6に日付が入っているものとします。

Sub PDF作成_Click()
Dim Ffldr As String
Dim Fname As String

Ffldr = "C:\Users\ユーザ名\Documents\検査成績書\PDF\"
Fname = Ffldr & Range("A11") & Format(Range("B6"), "【yymmdd】")

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=Fname _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End Sub

ドキュメントフォルダの検査成績書内PDFフォルダに作成します。

ファイル名は検査対象品名【日付】となっています。

単にマクロの記録で用意して、少し弄っただけですけど^^;

Office2016をインストールしてみた

Windows Insider Programからこんなメールが来てた。

・・・・Windows Insider の皆様は、Windows 10 で Office 2016 のプレビュー版をご利用いただけるようになりました。Office 2016 のプレビュー版には新機能が搭載されており、2015 年の後半に Office ユーザーへの配信を予定しています。 Windows Insider の皆様には、早期にフィードバックをお寄せいただきたいと考えております。 ぜひ今すぐ Office 2016 Preview をダウンロードして、ご利用ください。

なので、早速サイトに行ってダウンロードしました。

インストール！

途中で開けるようでしたが、待ちました。

終わったようなので、Excelを開いてみました。

Microsoftのアカウントでアクティベート出来そうで、出来ないようです。

サイトに書いてあるプロダクトキーを入力することでアクティブ化出来ました。

若干のUI変更ぐらいで2013と大差変わりません。

赤で囲んだ部分に親切？な検索項目が出来てますね。

VBEもちょっと見ただけですけど変わってないようです。

実際には何もやってないので、詳しくは分かりませんがタダなのでｗどうでしょうか？

Microsoft Office Home and Business 2013 [プロダクトキーのみ] [パッケージ] [Windows版](PC2台/1ライセンス)

Outlook予定表作成をExcelのVBAで行う

リクエスト頂きましたので書いていきます。
だいぶ前に作ったものなので、詳細などは忘れている部分もあり、
また、訳もわからずに使っているコードもあります^^;
なので細かい質問などに答えられる自信は無いことを宣言しておきます（滝汗）。

申し訳ないことにコードは一部丸々コピーしているものも有ります。出典は以下です。
三流君VBAでOutlookを操作する
Outlook 研究所 | Outlook を徹底活用する方法を研究するサイトです。

予定表作成のブックは2つのシートがあります。
①Sheet1に実際の予定を作成する表とコントロールを配置しています。
　VBAコードもSheet1に書いてます。
②Sheet2に表に入力規則から入力する既定の各リストを羅列しています。
　ただリストを使わなきゃ要りませんし、Sheet1の端っこに記入してもいいです。
　
Sheet1の記入
　各コントロールを適当に配置します。

　MonthView Control                                        日付の入力に使います
　CommandButton1(入力のクリア)                  クリアに使います
　CommandButton2(保存しないで閉じる)       ブックを閉じます
　CommandButton3(予定作成！)                     予定表作成を実行します
　
　表は図のように作成します。

　L列には「=IF(K14="◯",TRUE,FALSE)」
　O列には「=IF(N14="◯",TRUE,FALSE)」と関数を入れた後、目障りなので非表示にしときます。
　なおKとL列には入力規則で”○”をリストにしておきます。

　一応、一度に10件までは予定を立案できるようにしてあります。
　分類項目等をドロップダウンリストから選択するようにするならば、該当セルに設定しておいてください。
　分類項目を使いたい場合は、先にOutlookの分類項目を作成しておかなくてはイケマセンよ～
　
MonthView Controlを配置（無くてもいいです）
　 MonthViewのコード（カレンダークリックで日付入力）
Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
Dim Ni As Long
Ni = Range("B" & Rows.Count).End(xlUp).Row
Range("B" & Ni + 1).Value = MonthView1.Value
End Sub

CommandButton1のコード
　10件を超えて連続して予定を入れていきたい際には一発クリアで便利。
　項目が増えることも考えて、余計な書き方になっています。
Private Sub CommandButton1_Click()
Dim R1 As Range
Set R1 = Range("B14:K23,M14:M23,N14:N23,P14:P23")
R1.Value = ClearContents
End Sub

CommandButton2のコード
　保存せずに閉じるだけのコード
Private Sub CommandButton2_Click()
Application.DisplayAlerts = False
ThisWorkbook.Close
End Sub

CommandButton3のコード
　いよいよOutlook予定表を作成します。
'//
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Sub CommandButton3_Click()
'outlook用宣言
Dim oApp As Object
Dim myNameSpace As Object
Dim myFolder As Object
Dim objITEM As Object
Dim objWShell As Object
Dim flg As Boolean
Dim hwnd As Long
Dim i As Integer
Dim jDAte As Date
Dim jTime As String
Dim jCate As String
Dim jLon As Integer
Dim jSub As String
Dim jBdy As String
Dim jRem As Boolean
Dim jRet As Integer
Dim jAll As Boolean
Dim jBusy As Integer
'クラス名
Const FCLASSNAME As String = "rctrl_renwnd32"

'Outlook 起動
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application") '既に起動している場合に取得
If Err.Number <> 0 Then
Set oApp = CreateObject("Outlook.Application")
flg = True
End If

On Error GoTo 0

'予定表各項目
For i = 14 To 23 '予定表内容のセル番号を指定
jDAte = Range("B" & i) '予定日
jTime = Range("C" & i) '予定時刻
jCate = Range("E" & i) '分類項目
jLon = Range("D" & i) '時間
jSub = Range("F" & i) '件名
jBdy = Range("G" & i) '本文
jRem = Range("L" & i) 'リマインダー
jRet = Range("M" & i) '通知時間
jAll = Range("O" & i) '終日指定
jBusy = Range("P" & i) '公開方法


If Range("B" & i) = "" Then Exit For '空白だったらループ脱出

If flg Then
Set myNameSpace = oApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(9) '起動時フォルダーを指定
myFolder.Display
Set objITEM = oApp.CreateItem(1) '予定表作成画面を指定
objITEM.Display '編集画面を表示

Else
Set objWShell = CreateObject("WScript.Shell")
objWShell.AppActivate oApp.ActiveWindow.Caption 'アクティブ化
hwnd = FindWindow(FCLASSNAME, vbNullString)
SetForegroundWindow hwnd '前面に持ってきて
objWShell.SendKeys "%R" '元に戻す
Set objWShell = Nothing 'ここで終わった後に、
Set objITEM = oApp.CreateItem(1) '予定表作成画面を指定
objITEM.Display '編集画面を表示

End If

'予定表内容詳細
objITEM.Subject = jSub '件名をセット
objITEM.body = jBdy '本文をセット
objITEM.Duration = jLon '時間（分単位）でセット
objITEM.Start = DateValue(Format(jDAte)) & " " & jTime '予定日と開始時刻をセット　時刻のスペースはOutlookで必須のよう
objITEM.AllDayEvent = jAll '終日指定するか？
objITEM.ReminderSet = jRem 'リマインダーセット（←はfalseの場合しない）
objITEM.ReminderMinutesBeforeStart = jRet 'リマインダー（開始何分前にアラームを出すか？）
objITEM.Categories = jCate '分類項目をセット
objITEM.BusyStatus = jBusy '公開方法をセット0～4
objITEM.Save '保存して
objITEM.Close 2 '閉じる

Next i '次のセルの日付へ

Set oApp = Nothing 'ループ脱出してもOutlookは何もしない

End Sub

　予定表に追加したい項目があるのならば、ここを参照して追加してください。

　なお、公開方法の内容は下記。
　0空き時間
　1仮の予定
　2取り込み中
　3外出中
　4他の場所での作業

Outlook予定表作成の流れ
1.予定日のカレンダー日付をクリックする
2.開始時刻入力（ex.8時30分→8：30）
3.時間を入力。「分」単位で入力する
4.分類項目(DDリストから）選択または無指定
5.件名を(DDリストから）選択または自由入力
6.本文を(DDリストから）選択または自由入力
7.通知設定の有無をDDリストから選ぶ　○で有り
8.通知時間セット　分単位で
9.終日指定をDDリストからセット　○で有り
10.公開方法0～4　セット空欄は空き時間

11.「予定作成！」ボタンをクリック→Outlook起動、予定立案
12.「入力のクリア」をクリックして、続いて予定表作成するか
「保存しないで閉じる」をクリックして終了

あれ～分かりやすい説明に成った？上手く出来なかったかもしれません(TдT)
わからなかったらコメントしてください。すみません・・・書き方下手になったなぁ～
Office2007で作成して、10でも13でも使えてますので問題は無いかと思います・・・・

システム手帳 革製 A5 カード 名刺 ペン入れ リング22mm ブラウン ブラック

別のブックを開いてコピーする

ブック間でコピーするのは決まったところに決まったものを貼り付けるとなると一々が面倒です。
開いてコピーして、ペーストするブックをアクティブにして貼り付けて、コピー元閉じて・・・
といっても複数のブックから集計することはママあります。
手っ取り早くVBAでやっちゃいましょう。

Private Sub CommandButton1_Click()
Dim flag As Boolean
Dim Fdir As String
Dim FPss As String
Dim FileName As String
Dim Opnbook As Workbook
Dim Z As Worksheet
Dim H As Worksheet

'チラついて五月蝿いのを防止
Application.ScreenUpdating = False

Fdir = "C:\Users\ユーザ名\Documents\フォルダ名\"
FPss = Fdir & "開くブック.xlsx"
FileName = FPss

flag = False

'今開いているブックを調べる
For Each Opnbook In Workbooks
If Opnbook.FullName = FileName Then
flag = True
Exit For
End If
Next Opnbook

'目的のブックが開いてなければ開き、名前をセット
If flag = False Then
Set Opnbook = Workbooks.Open(FileName)
End If

'コピー元先のシートをセット
Set Z = Opnbook.Worksheets("sheet1")
Set H = Workbooks("アクティブブック.xlsm").Worksheets("sheet1")

'コピー元をアクティブにする
Opnbook.Activate

'コピペ　今回コピー元セルには計算があると仮定して、値で貼付けとしている
'２箇所コピペすることにしてある
Z.Range("A1:A10").Copy
H.Range("A5").PasteSpecial Paste:=xlValues

Z.Range("A11:A20").Copy
H.Range("B5").PasteSpecial Paste:=xlValues

'コピー元にもよるけど保存するか否かのダイアログがでたりするのでそれは表示させないで閉じる
Application.DisplayAlerts = False
Opnbook.Close

'主たるブックをアクティブにする
Workbooks("アクティブブック.xlsm").Activate
H.Range("A1").Select

End Sub

"開くブック.xlsx"をアクティブブックのセル内でリスト化して代入させると複数のコピー元ブックを必要に応じて開くこともできるでしょう。（リスト=ブック1、ブック2、ブック3・・・とか）
その時には貼り付け先も考えてね。上書きされちゃうから。

あと画面の更新時のチラツキは邪魔なんで、”Application.ScreenUpdating = False”と書きました。
チラツキ防止には色々あるようだけど1行で済むので・・・
チラツキはメモリ消費もかなりあるようで、場合によっては、Excelが落ちる原因になってる場合もあります。
別のブックではこの1行で落ちなくなったので、一応は実績有りです。

アヲハタ ビーフペースト 73g×6個

 コレジャナイ

ビッグデータのマップ風をエクセルで作る

暇だったんで遊んでみたｗ
Excel2013が必要ですが、”Office 2013 Professional Plus”か”Office 365 ProPlus”、
若しくはExcel 2013単体バージョンが無くては使えません。
自分は”Office 2013 Professional”環境です。Pulsついてませんけどいいんでしょうか？

Microsoft Power Query for Excel は、データの検出、アクセスおよびコラボレーションを簡略化することで、Excel のセルフサービス ビジネス インテリジェンス環境を拡張する Excel アドインです。

ってことなので、Microsoft Power Query for Excelをまずインストールします。

Download Microsoft Power Query for Excel from Official Microsoft Download Center

次に今回の本丸Power Map for Excelをダウンロードして、インストールします。

Power Map for Excel

インストール時にVisual C++ 2013 Runtime Libraries(x86)が無いとインストールするように促されます。

I agreeとNextとCloseだけですので英語でも怖くありません。

双方ともインストール後にはExcelアドインとして有効になっているとは思いますが、もしなっていないようなら
COMアドインを開いて有効にチェク入れましょう。

地震マップを作りたいと思ったんで、Hi-Net(http://www.hinet.bosai.go.jp/）からHi-net自動処理震源リストを拾ってこようと

Power Query のWebから取得にURLいれて、試みる・・・・も失敗。
Power Query ではログイン認証の壁を超えることは出来ないようなのであった(´・ω・｀)ｶﾞｯｶﾘ…
Yahoo!からはデータとれたけどあまりにもしょぼかったので以下Power Queryは割愛。
そんなに難しくは無いんで弄ってみてください。気象庁の降水量とか環境省の花粉量とかPM2.5とかいいんじゃないかな？

さて、Hi-Netの方のデータは仕方ないので、ページのデータをコピペしてセルに貼り付けてみた。

横一行一文のテキストデータだったので、Value関数とMID関数で各データを振り分けました。これで準備は整いました。

データの入ったセルを選択した状態で、[挿入]-[Power Map]をクリックします。

じゃ～ん！地図が出てきたぞ！！！

というか、これアドインのレベルじゃね～Excelでもな～～～いｗ
などと若干のﾜｸﾜｸ感を抱きつつ、次のステップへ。

Hi-Netでは、地図の位置データは緯度経度なので、それをチェックします。
もし、元データが住所等でしたらそれを選べばいいです。

[次へ]

値はM（マグニチュード）を選び集約なしに。

時間は時間（なし）にして、右上にちっさくある時計をクリックして「データが少しの間表示されます」を選択します。

歯車アイコンはオプション設定です。レイヤーオプションの影響範囲を200%、シーンオプションのシーンの長さを15秒にしました。

再生ボタンをポチリ。

でけた～テーマをエアリアルカラーにもした！
しかもツアーのところにある「ビデオの作成」を押してみると・・・

MP4で動画になったぁぁ

地震 - YouTube

結構簡単にできるものです。
色んなデータで遊んでみるのも面白いかもね。

入力時の自動スクロール

大量のデータを打ち込んでいて、ウィンドウの一番下まで行ってしまうとかなり見難くなりません？

私はなります。

どうせなら、入力セルは見やすい位置にずっていてくれたほうが助かります。

なので、自動でスクロールして選択セルは定位置にするマクロが必要です。

WorksheetのSelectionChangeイベントに書いていきます。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim Scrl As Long
Dim i As Long

Application.ScreenUpdating = False 'スクロールの際のチラツキ？防止の為

For i = 0 To 94 '100行目まで

Scrl = 6 + i

If Target.Row > Scrl Then '6行目を超えたら

ActiveWindow.ScrollRow = Scrl - 5 '1行スクロール=定位置

End If
Next i

End Sub

これだけだとあまり役に立たないので、他のマクロと組み合わせます。

まあ、こんな感じ。