アラフィフおやじログ

はい 前回 に続いてOutlookネタです。というか、これはほぼまんまコピペですけど。 もともとは添付ファイルを添付忘れたり、宛先に「様」付け忘れたりすることが多かったので何とかできる範囲でチェック強化できないかなぁと悩んでいた次第で、ほぼ以下のサイトの丸パクリです。 ◆参考サイト https://se.ekaki-j.com/outlook-security/ http://tooljp.com/qa/recommended-VBA-samples-Outlook-prevent-mail-incorrect-sending-B42C.html ◆ソースコード ' ' メール送信前チェック ' Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) On Error GoTo Exception Dim maxCnt As Integer Dim strCC As String Dim strBody As String maxCnt = 0 strCC = vbCrLf strBody = Item.Body ' 添付ファイルチェック If InStr(strSubject & strBody, "添付") > 0 And Item.Attachments.Count = 0 Then If MsgBox("添付ファイルを忘れている可能性があります。本当に送信しますか？", vbYesNo + vbQuestion) = vbNo Then Cancel = True Exit Sub End If End If Dim objRec As Recipient For Each objRec In Item.Recipients strCC = strCC & "●" & objRec.Name &...

タイトルのまんまです。よく見積書とか請求書をメールで送信してくる人いるじゃないですか、そういう時にメールの内容見てから、わざわざフォルダに保存しないといけないんですよねぇー、、これが面倒くさい。で、Outlookでメール受信したときに指定のアドレスからで指定のファイル名のやつの場合に保存ダイアログいきなり開いてくれるようにマクロ準備したっす。といっても丸々コピペですが、、、 で添付ファイル本体はなぜかZIPパスワードがかかっているので、本当はパスワード付ZIPを自動で解凍してくれるところまでやりたいんですが、そこまでは余力なかった。 パスワード付きファイル展開実装しました。エラーチェックとか盛り込んでいないのでとても危険です。あとMS非推奨の方法だけどDLLなしで対応したかったので仕方なくこの方法で対応しました。ほかにも こういう方法 もあるそうです。 ウイルス仕込まれたら危険なので本来はメールファイル添付でやり取りするよりかは素性のはっきりした Redmine とかプロジェクト管理ツールにファイル集約した方が安全な上に情報集約できていいと思うんですがねぇ、、ファイルサーバにデータ保存はルーチンには向いていますけど、そんなルーチンは自動化すべきと考えているのでやはりファイルはツールで集約管理すべきですね。 どうしてもファイルを送信したいんだぁという場合はオンラインストレージにファイルを保存してからパスワードは口頭で電話連絡するというのが本来のあるべき姿のような気がする。それか、 Skype とか Slack の様なチャットでやり取りのいずれかでしょう。 ◆参考サイト https://outlooklab.wordpress.com/2016/05/21/outlook-%E3%81%A7%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E9%81%B8%E6%8A%9E%E3%81%AE%E3%83%80%E3%82%A4%E3%82%A2%E3%83%AD%E3%82%B0%E3%82%92%E8%A1%A8%E7%A4%BA%E3%81%99%E3%82%8B%E3%83%9E%E3%82%AF%E3%83%AD/ http://vba-andmore.hatenablog.com/entry/2016/07/15/...

とある作業はEXCELのボタンを押せばある程度簡単に作業できるところまではやったんだけど作業自体が漏れてしまうということがあって、何とかできないかなぁと思っていました。色々とどんな手があるかと考えていたら。Outlookには予定表なるものがあるじゃないですか。なのでそれを使ってリマインダーしてみようと挑戦。OutlookのVBAがあるらしいですが、Outlookは難しそうなのと引継の時とかにEXCELシートで1年分のアラートをまとめて登録することも視野に入れていたのでEXCEL/VBAで実装してみました。 アラートだけなので会議出席依頼の返信不要オプションを指定して複数人でアラートを共有するようなことで考えています。 とりあえず意図通り動いてくれましたよ。100%コピペです。 そしてエラー実装ゼロ、まぁ落ちても被害はそこまで大きくないので、、、、 しかしシステムの仕事長いのに未だに綺麗なコード書けないし、変数の命名とかダメダメだし、テストコード書けないほぼ素人なので今年こそは何とかしたいんですけどね。 ◆参照サイト https://outlooklab.wordpress.com/2012/05/19/excel-%E3%81%AE%E3%83%87%E3%83%BC%E3%82%BF%E3%82%92%E3%82%82%E3%81%A8%E3%81%AB%E4%BC%9A%E8%AD%B0%E5%87%BA%E5%B8%AD%E4%BE%9D%E9%A0%BC%E3%82%92%E9%80%81%E4%BF%A1%E3%81%99%E3%82%8B%E3%83%9E%E3%82%AF/ http://www.ken3.org/cgi-bin/group/vba_outlook_Appointment.asp https://oshiete.goo.ne.jp/qa/5722929.html http://jus7733.hatenablog.com/entry/2015/05/27/164738 http://officevba.info/outlookschedule/ https://docs.microsoft.com/ja-jp/office/vba/api/outlook.appointmentitem.send(m...

DynamoDB 用のJSONを作成して DataPipeline に流すのに JSONがいるので色々と調べながら作成してみた。 EXCEL VBAなのは編集するときに色々と融通を利かせたいからです。 本当はかっちょよいWebのやつとかで作れればいいんですけど そこまでのスキルがないのですよ。それはご愛敬だww そして Git やってみました。色々と分からないことだらけですが とりあえず、上げてみた。 https://github.com/Otazoman/excel_tool.git        処理の流れとしては 1.EXCELのシートで元シートを作成 2.元シートにデータを投入 3.EXCELでJSONデータを生成し WinSCP で S3 にアップロード エラーハンドリングはほとんど考慮できていないし しょぼいコードなので何とも言えない。 ちなみにIDとPW設定はWinSCPのものに依存するので S3側にアクセスできるユーザをあらかじめ IAM で作成しておく必要が あります。 ◆投入用JSONデータフォーマット参考 https://docs.aws.amazon.com/ja_jp/amazondynamodb/latest/developerguide/SampleData.LoadData.html まだDynamoにデータ投入していないので、きちんと動くかは これから検証してみる必要ありなんですが。 検証してみて不具合出てきたら更新はしていく予定です。 フォーマット変わらない限りは使えるかなぁと思っていますが、どうだろうか。

とりあえず、JSON形式なデータがEXCELに格納されているので JSONの中に何個要素があるかをカウントするマクロです。 カウントしたいデータのデータ形式 {"key1":"value1","key2":"value2","key3":"value3","key4":"value4"} まぁ参考にすらならないかもですが、、、 DynamoDBのファイル作るときに役に立つかも Function operationCheck() Dim ts As Worksheet Dim i As Long Dim j As Long Dim fRow As Long Dim wStr As String Dim wArray() As String Dim wVal As String Set ts = ThisWorkbook.Worksheets("Sheet1") fRow = ts.Cells(Rows.Count, 1).End(xlUp).Row + 1 For i = 2 To fRow - 1 wStr = Replace(ts.Range("B" & i).Value, "{", "") wStr = Replace(wStr, "}", "") 'カンマ区切りの文字を1個ずつ配列に格納 wArray = Split(wStr, ",") For j = 0 To UBound(wArray) Select Case j Case Is = 0 wVal = "0" Case Is = 1 ...

仕事でHTMLファイル編集する必要が出てきたので EXCELVBAで組んでみた。 大量のHTMLファイルを修正する際に使えそうなので メモしとくまぁ、過去問の応用編みたいな感じです。 相変わらずエラー制御は甘い ちなみに<は全角に置き換えてるんで注意ください。 Option Explicit Public Type metaExcelRtn code As Boolean excelFilepath As String meta_Discription As String meta_Keyword As String meta_title As String End Type 'meta変換用EXCELシート読込 Function readMetaExcel(readmetaExcelbook As Variant) As metaExcelRtn() On Error GoTo Error_Sub Dim orgExcel As Workbook Dim orgWorksheet As Worksheet Dim sn As Long 'シート番号 Dim sc As String '開始列 Dim ec As String '終了列 Dim rowCount As Long Dim colCount As Long Dim i As Long Dim rtnVal() As metaExcelRtn Dim t_title As Long Dim t_keyword As Long Dim t_description As Long Dim fpath As Long Const STAR = "J" Const ENDR = "L" '読込EXCEL指定 Set orgExcel = Workbooks.Open(readmetaExcelbook) sn = InputBox("読込対象のシート番号を入力してください。...

最近、業務自動化を研究していてその過程で Webのスクショ取る業務があってそれ自動化できないかと 思ってACCESS/VBAでやってみました。 IEしか対応していませんが・・・・・ IEShot という全画面キャプチャ取得できるコードがあり 有効活用させていただきました。ありがとうございます。 下記の構造でテーブルの準備が必要です seqNo targetURL targetSheetName startCol endCol statRow endRow targetComent エラーハンドリングも適当です。ご使用は自己責任で お願いします。 Option Compare Database 'Sleep関数用 Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'Sleep関数用 'キャプチャ用 Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) '画面アクティブ制御 Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ShowWindowAsync Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long '取得対象用構造体 Type RetVal SiteUrl As String ExcelsheetName As String ExcelComent As String ...

前回 の宿題事項の下記4点について対応できた。 思ったよりあっさりと実装できた。 1.EXCELシートのシート名を引いてくるのと選択式にする。 　→選択式にしやした。 2.ファイル名を再帰的に取得するのかしないのかを選択式にする 3.再帰的に取得する場合にフォルダ名も取得するのか選択式にする 4.フォルダ名の取得を選択式にする。 　→フォルダを選択すれば再帰的に出力するように改修 モジュール以外にも手を入れるところがあったんで。 フォーム フォームモジュール側 ----------------------------------------------------------------------------------------------------------------------- Option Explicit Sub getFileName_Click() ' ' フォルダからファイル名を取得して一覧にして別のEXCELシートに保存する。 ' Dim dlg As Object Dim dlgAns As Boolean Dim getForder As Variant '取得対象フォルダ Dim getFile As Variant '取得対象ファイル Dim outSheet As Variant '出力用シート Dim retVal As String Dim optSelect As String Dim startTime As Date '処理時間計測用 Dim endTime As Date '処理時間計測用 startTime = Now 'カレントディレクトリの指定 ChDir CurDir '保存対象ファイルの指定 outSheet = Application.GetOpenFilename("EXCELファイル(*.xlsx),*.xlsx , EXC...

前回 作成したVBAを使ってて不便な点が1つ出てきたので考えました。 よくよく考えるとフォルダ名一覧を1個のファイルにまとめたいよなぁ。 だって大体が一まとめにしないといけないケースが多いわけだし。 ということでモジュール側でファイル一覧を1個のEXCELにシートを追加して 出力できるように改修しました。モジュール側だけ改修したんでそっちだけ モジュール側 ----------------------------------------------- Option Explicit 'refer ' http://ameblo.jp/gidgeerock/entry-11584846307.html ' https://oshiete.goo.ne.jp/qa/1828986.html ' http://officetanaka.net/excel/vba/file/file07.htm ' http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html ' http://officetanaka.net/excel/vba/tips/tips39.htm ' https://gist.github.com/gitspopovic/2963865 ' http://vba-geek.jp/blog-entry-294.html ' http://vbaexcel.seesaa.net/article/148305417.html ' http://d.hatena.ne.jp/bhunji2000/20091030/1258133771 ' http://www.239-programing.com/excel-vba/func/func072.html ' v2 ref ' https://www.moug.net/tech/exvba/0150120.html ' http://officetanaka.net/excel/vba/sheet/sheet03.htm ' http://hensa40.cutegirl.jp/archives/705 ' ht...

この前 は業務フローをシートにというパターンでしたが 今回はファイル1個に業務を記載してくれているパターンなので 指定したフォルダからファイル名の一覧を抜き出す必要が出てきました。 とゆうかシートの業務一覧とかファイル名のとか統一しろよと思いつつも・・・・。 両方組合せとかその他イレギュラーパターンも多々あるしそれは今後の話ということで ひとまずはマクロ組んでみました。 とりあえず40を超えてから3社転職してるんで、こういうのは蓄積しておかないと。 忘れるし。パッケージみたいになっているほうがありがたい。 フォーム側 ----------------------------------------- Sub getFileName_Click() ' ' フォルダからファイル名を取得して一覧にして別のEXCELシートに保存する。 ' Dim dlg As Object Dim dlgAns As Boolean Dim getForder As Variant Dim outSheet As Variant Dim retVal As String Dim startTime As Date '処理時間計測用 Dim endTime As Date '処理時間計測用 startTime = Now 'カレントディレクトリの指定 ChDir CurDir 'ファイル名取得対象フォルダの指定 Set dlg = Application.FileDialog(msoFileDialogFolderPicker) dlgAns = dlg.Show If dlgAns Then getForder = dlg.SelectedItems(1) Else getForder = "" End If '保存対象ファイルの指定 outSheet = Application.GetOpenFilename("EXCELファイル(*.x...

ありがちだけどメールのテンプレートをEXCELに作って そいつを送信するとか言うCDOのメール送信用マクロ作成しました。 まぁ、決してやってはいけない用途で作ったんですが・・・・。 だいたい1つずつ手でメールを打つのもなぁ。 かといってBccで全員に送るのもなぁ。というので けど本当は手書きでやるべきですがね。 ・EXCELを処理する本体。 ' AdressListにある区分、会社名、氏名を引いてきて ' 区分に応じたテンプレートのメールを送信する ' 区分に応じてメール件名、テンプレート、署名が可変となる ' ' Sub ボタン1_Click() Const Replaceword = "●●" 'メールで埋め込みしたい場合の置換前文字列 Dim rtn As String Dim selectFlg As String '送信テンプレート判定用フラグ Dim Category As String '送信属性(本文判定用) Dim toMailaddr As String '宛先メールアドレス Dim toCompany As String '会社 Dim toName As String '名前 Dim toHeader As String '宛名 Dim messagetxt As String '本文 Dim signature As String 'メール署名...

業務フローをEXCELを描くことがよくありますが、そのとき ご丁寧にもシート名に業務を書いてくださっている方が いらっしゃいます。 んで、業務一覧をまとめたいときに一々転記するのもかったるいんで VBAでシート名を取得して一覧にするやつを組みました。 ファイルを読み込んで、保存するだけのいたってシンプルなものです。 例のごとくエラー制御は甘いままです。(いいかげん鍛えないと・・・) フォーム側( ボタンを1個作る) ----------------------------------------------------------- Private Sub btn_getSheetName_Click() 'refer ' http://officetanaka.net/excel/vba/tips/tips154.htm ' http://www.moug.net/tech/exvba/0060013.html ' http://vbaexcel.seesaa.net/article/148313379.html ' http://officetanaka.net/excel/vba/file/file02.htm ' http://excelvba.pc-users.net/func/func4.html ' ' EXCELブックからシート名を取得して別のEXCELに出力する ' Dim getFile As Variant Dim setFile As Variant Dim retVal As String '処理時間計測用 Dim startTime As Date Dim endTime As Date startTime = Now ChDir CurDir 'カレントディレクトリ '抽出対象と保存対象を読出 getFile = Application.GetOpenFilename("EXCELファイル(*.xls),*.xls, EXCELファイル(*.xlsx),*.xlsx...

先ほどのはEXCELですが、実はVLOOKだとレコード重複とかあるんで 比較をACCESSでした方がいいことと、一々ACCESSテーブルをEXCELに 落としてpingして結果をインポートとかいう馬鹿げたことをしたくないので ACCESSに先ほどのやつを移植。 短時間でやっているから、エラーチェックとか細かいのなしです。 まぁそんなに使わんしね。備忘録で Private Sub コマンド1_Click() '参照URL：http://accessvba.pc-users.net/ado/move_record.html ' 　http://www.moug.net/tech/acvba/0080026.html ' Dim cn As ADODB.Connection Dim rs As New ADODB.Recordset Dim tblName As String Dim IpAddr As String Dim fieldSearch As String tblName = "t_diff" Set cn = CurrentProject.Connection rs.Open tblName, cn, adOpenKeyset, adLockOptimistic, adCmdTableDirect rs.MoveFirst Dim objWSH As Object, oEx As Object Dim result As String Const msg = "ラウンド トリップの概算時間" Do Until rs.EOF IpAddr = rs![IPアドレス管理表] fieldSearch = "IPアドレス管理表=" & "'" & IpAddr & "'" cmd = ...

とあるツールとEXCELのIPアドレス管理台帳で 差異が出やがったんで手でpingうつのもだるいと思って 調べたらありましたよ。手でやったら10分コースかな 検索結果 ざくっとパクらせていただきました。 あざっす。んで今自動ping終了しました。 けどEXCELだIPの差分出してるのACCESSだからACCESSで 完結した方がいいな。今後の課題 Sub test() Dim objWSH As Object, oEx As Object Dim result As String Const msg = "ラウンド トリップの概算時間" For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row cmd = "cmd.exe /c ping -n 1 " & Cells(i, 1) Set objWSH = CreateObject("WScript.Shell") Set oEx = objWSH.Exec(cmd) Do While oEx.Status = 0 DoEvents Loop result = oEx.StdOut.ReadAll If InStr(result, msg) = 0 Then Cells(i, 2) = "PingNG" Else Cells(i, 2) = "PingOK" End If Set objWSH = Nothing Next End Sub

ACCESSのVBAとは違うのですがEXCELのVBAで作りました。 経緯はというとGoogleスプレッドシートで集計したメール件数を 1か月分まとめて件数推移を見たいという時に使うやつです。 グラフ作るの面倒なので少しプチ楽にしてみました。 グダグダコードですが一通りやりたいことはできたかなぁと。 エラー処理とかは不十分です。まぁ三流PGでして今後の課題ということで目をつぶって いただけると・・・ 取込想定データのフォーマット A列にカテゴリ、B列にメール受信件数 シート名は年月日(yyyymmdd)が前提となっています。 *5/14：若干、コード微修正 　自動で閉じるようにした。作業月の前月をprefixに *5/25：若干、コード修正 　ラベル毎集計機能追加と円グラフ自動生成 フォーム側(ボタン1個作ってね) -------------------------------------------------- Private Sub cmdStart_Click() 'ref http://www.moug.net/tech/exvba/0150079.html Dim FN As String Dim EF As String FN = Module1.fileOpen Module1.GetData (FN) 　　Module1.CategoryGetData (FN) EF = MsgBox("処理が終了しました。") If EF = vbOK Then Application.DisplayAlerts = False Application.Quit ThisWorkbook.Close SaveChanges:=False End If End Sub モジュール側 -------------------------------------------------- 'refer： ' http://officetanaka.net/excel/vba/tips/tips154.htm ' http://www.officepro...

手作業でやるのも大変なので必要に迫られて VBScriptで指定フォルダ内のファイル数をカウントするスクリプトを 作ってみました。 指定したフォルダ内のファイル数をカウントして "フルパスフォルダ名","ファイル数"という形式でファイル出力するという ほんまに超単純な機能を持つスクリプトです。スピードは3,000ファイル処理で30秒と 実用にはやや厳しいかもしれないです。出力したファイルはEXCELで加工 ＊たぶんファイル書き込みの前の条件判定とループのダブルミックスで重いのかも 知れないですね・・・。 保存されているファイルの先頭にはｙｙｙｙmmddと日付がついているので 日付毎のファイル数の推移を見れば月毎の繁閑を見ることができるんですが それは別の機会に・・・。 ’指定フォルダ内のファイル数をカウントしてログファイルに出力 Set fso = CreateObject("Scripting.FileSystemObject") Private Const TARGETFOLDER = "分析パス指定" 'カウント対象パス Private Const OUTFILENAME = "ログファイル名" '出力ログ Call Main() WScript.Quit 0 Sub Main() Dim objFS, objFolder Dim strm, dest Set objFS = CreateObject("Scripting.FileSystemObject") ' 出力ログのストリームを生成 dest = objFS.BuildPath( GetScriptPath(objFS), OUTFILENAME ) Set strm = objFS.CreateTextFile( dest ) ' ファイルをリストアップ Set objFolder = objFS.GetFolder( TARGETFOLDER ) Call WriteFilePathAll(objFolder, strm) strm.Close ...

で実際にフォームでプログラムを使用する際に埋め込んでみたわけです。 まあグタグタですな。ダイアログボックスはNETで調べると案外出てます。色々調べて完成はさせてみましたが、フォーマット固定が多いんでどう使うかは考えものです。 アップローダあればアップして、いろんな人に評価して頂いてソースを綺麗にしたいです。 '# '#　参照ボタンクリック(CSV取込) '# Private Sub Cmd_import_Click() '参照ボタンクリック時(データインポート) Dim j, k As Integer '複数strpass選択時のカウンタ Dim m, n As Integer 'テーブル名取得用カウンタ Dim strpass As String 'インポート対象パス Dim strVal As Boolean '関数結果受け取り Dim strFName As String 'テーブル名取得用、ファイル名入力用 Dim strpassW As String 'インポートパス分割ワーク用 Dim strMsg As String Dim strSheetName As String 'EXCEL取込時のシート名格納用 'テーブルバックアップ用 Dim strTableName As String 'テーブル名 Dim db_Dao As DAO.Database Dim TableLoop As TableDef '拡張子判別用 Dim strEXT As String '拡張子格納用 '関数受取 Dim strRtn A...

 この辺りはNETで調べれば出てくるんでまあ掲載の必要もないですが・・・・  参考までに・・・・。EXCELのインポートとエクスポート部分です。   Function FromExcel(strTableName As String, strImportTableName As String, strXlsFileName As String, strSheet As String) '==================================================================== ' テーブルから定義情報を取得してインポートする。 ' 可変EXCEL(カラム追加の可能性のあるテーブル)インポート関数 ' 2010.05.19 Created By M.Nishimura '＊使い方 ' str_rtn = FromExcel(定義テーブル名,取込テーブル名,EXCELファイル名) '＊戻り値 '　True：処理正常終了 '　False：処理失敗 ' '==================================================================== Const COLUMCNT = 256 'カラム数 Dim db_Dao(1) As DAO.Database Dim Rst_Dao(1) As DAO.Recordset Dim Qdf_Dao As DAO.QueryDef Dim xls As Excel.Application Dim wkb As Excel.Workbook Dim vntList As Variant 'EXCELのセル数値取得 Dim strTname As String '定義テーブル名 Dim striTname As String 'インポート先テーブル名 D...