Windows7 をホストにして オンプレミス HackMD サーバーを立ち上げてみた

発端

Twitter上の以下スレッドのやりとりが元で、はけたさんの発言から知ったのがきっかけです。

調べてみるとオンプレミスで構築できるという情報があったので、「会社で使えそう」と考えて構築手順をまとめてみました。

次項記載の環境において、何も考えずに構築完了まで操作できます。

Windows7上で、仮想環境もDockerもGitも入ってない状態から最後までセットアップする手順は一応無かったので、備忘録としては割りと有意義かも知れません。

▼構築環境

ホストOS Windows7
仮想環境 Virtual Box
Dockerホスト 仮想CentOS7
仮想環境立上補助 Vagrant

1 VirtualBoxインストール

https://www.oracle.com/virtualization/technologies/vm/downloads/virtualbox-downloads.html

2 Vagrantインストール

https://www.vagrantup.com/downloads.html

3 PC再起動

4 Powershellを3以上に上げる

補足:2だと以下のメッセージが出ます。

C:\Vagrant\centos>vagrant init centos/7
Vagrant failed to initialize at a very early stage:

The version of powershell currently installed on this host is less than
the required minimum version. Please upgrade the installed version of
powershell to the minimum required version and run the command again.

  Installed version: 2

  Minimum required version: 3

4.1 インストーラーダウンロード

https://www.microsoft.com/en-us/download/details.aspx?id=54616

4.2 実行ポリシーを変更

Powershellを管理者権限で起動、以下コマンドを実行。

PS C:\> Set-ExecutionPolicy Remotesigned

補足:初期値だとスクリプトに署名がないと実行できない

4.3 インストール

PS C:\> E:\download\powershell\Win7AndW2K8R2-KB3191566-x64\Install-WMF5.1.ps1

5 Boxを検索し、CentOSインストール to 仮想環境

5.1 検索

https://app.vagrantup.com/boxes/search

↓ 検索

https://app.vagrantup.com/centos/boxes/7

5.2 フォルダ作成

PS C:\> mkdir C:\Vagrant\centos

5.3 Vagrant初期化

5.3.1 初期化コマンドを入力

PS C:\> cd C:\Vagrant\centos
PS C:\Vagrant\centos> vagrant init centos/7

以下、出力されるメッセージ。

PS C:\Windows\system32> vagrant init centos/7
A `Vagrantfile` has been placed in this directory. You are now
ready to `vagrant up` your first virtual environment! Please read
the comments in the Vagrantfile as well as documentation on
`vagrantup.com` for more information on using Vagrant.
PS C:\Windows\system32>

5.3.2 Vagrantfile編集

config.vm.network "private_network", ip: "192.168.33.10"    のコメントアウトを外す

5.3.3 仮想マシン起動

PS C:\Vagrant\centos> vagrant up

初回起動は結構時間がかかります。 ネットワーク環境にもよるかも。 自宅環境では約1時間かかりました。 以下、起動開始直後のメッセージ。

PS C:\Vagrant\centos> vagrant up
Bringing machine 'default' up with 'virtualbox' provider...
==> default: Box 'centos/7' could not be found. Attempting to find and install...
    default: Box Provider: virtualbox
    default: Box Version: >= 0
==> default: Loading metadata for box 'centos/7'
    default: URL: https://vagrantcloud.com/centos/7
==> default: Adding box 'centos/7' (v1905.1) for provider: virtualbox
    default: Downloading: https://vagrantcloud.com/centos/boxes/7/versions/1905.1/providers/virtualbox.box
    default: Download redirected to host: cloud.centos.org
    default: Progress: 5% (Rate: 191k/s, Estimated time remaining: 0:44:44))

以下、起動完了後のメッセージ。

PS C:\Vagrant\centos> vagrant up
Bringing machine 'default' up with 'virtualbox' provider...
==> default: Box 'centos/7' could not be found. Attempting to find and install...
    default: Box Provider: virtualbox
    default: Box Version: >= 0
==> default: Loading metadata for box 'centos/7'
    default: URL: https://vagrantcloud.com/centos/7
==> default: Adding box 'centos/7' (v1905.1) for provider: virtualbox
    default: Downloading: https://vagrantcloud.com/centos/boxes/7/versions/1905.1/providers/virtualbox.box
    default: Download redirected to host: cloud.centos.org
    default: Progress: 100% (Rate: 38791/s, Estimated time remaining: --:--:--)
==> default: Successfully added box 'centos/7' (v1905.1) for 'virtualbox'!
==> default: Importing base box 'centos/7'...
==> default: Matching MAC address for NAT networking...
==> default: Checking if box 'centos/7' version '1905.1' is up to date...
==> default: Setting the name of the VM: centos_default_1568814798579_93674
==> default: Clearing any previously set network interfaces...
==> default: Preparing network interfaces based on configuration...
    default: Adapter 1: nat
    default: Adapter 2: hostonly
==> default: Forwarding ports...
    default: 22 (guest) => 2222 (host) (adapter 1)
==> default: Booting VM...
==> default: Waiting for machine to boot. This may take a few minutes...
    default: SSH address: 127.0.0.1:2222
    default: SSH username: vagrant
    default: SSH auth method: private key
    default: Warning: Connection aborted. Retrying...
    default: Warning: Remote connection disconnect. Retrying...
    default: Warning: Connection reset. Retrying...
    default:
    default: Vagrant insecure key detected. Vagrant will automatically replace
    default: this with a newly generated keypair for better security.
    default:
    default: Inserting generated public key within guest...
    default: Removing insecure key from the guest if it's present...
    default: Key inserted! Disconnecting and reconnecting using new SSH key...
==> default: Machine booted and ready!
==> default: Checking for guest additions in VM...
    default: No guest additions were detected on the base box for this VM! Guest
    default: additions are required for forwarded ports, shared folders, host only
    default: networking, and more. If SSH fails on this machine, please install
    default: the guest additions and repackage the box to continue.
    default:
    default: This is not an error message; everything may continue to work properly,
    default: in which case you may ignore this message.
==> default: Configuring and enabling network interfaces...
==> default: Rsyncing folder: /cygdrive/c/Vagrant/centos/ => /vagrant

5.3.4 仮想マシンにログイン

PS C:\Vagrant\centos> vagrant ssh

6 Dockerインストール

6.1 OS更新

$ su -
# yum update
# yum upgrade

6.2 公式リポジトリのインストール

# yum install -y yum-utils device-mapper-persistent-data lvm2
# yum-config-manager --add-repo https://download.docker.com/linux/centos/docker-ce.repo

6.3 DOCKER CE のインストール

# yum install -y docker-ce docker-ce-cli containerd.io

6.4 docker-compose インストール

# curl -L https://github.com/docker/compose/releases/download/1.19.0/docker-compose-`uname -s`-`uname -m` -o /usr/local/bin/docker-compose
# chmod +x /usr/local/bin/docker-compose

7 Docker の起動・設定

7.1 Docker の起動

# systemctl start docker

7.2 自動起動設定

# systemctl enable docker

7.3 バージョンの確認

# docker --version

7.4 プロキシの設定

# mkdir -p /etc/systemd/system/docker.service.d
# vi /etc/systemd/system/docker.service.d/http-proxy.conf

/etc/systemd/system/docker.service.d/http-proxy.conf

[Service]
Environment="HTTP_PROXY=http://:@:" "HTTPS_PROXY=http://:@:" "NO_PROXY=localhost"

7.5 Docker 再起動

# systemctl daemon-reload
# systemctl restart docker

8 Git インストール

# yum install git

9 HackMD インストール・起動

9.1 githubからclone

# git clone https://github.com/hackmdio/docker-hackmd.git

9.2 HackMDを起動

# cd docker-hackmd && git pull
# docker-compose up

9.3 ブラウザで動作確認

http://192.168.33.10:3000

f:id:wd4096:20190919010253p:plain

オンプレミスでHackMD

 

▼参考サイト

  1. https://qiita.com/ozawan/items/160728f7c6b10c73b97e
  2. https://qiita.com/tettsu__/items/e1e445c8d7a975829902
  3. https://qiita.com/ymasaoka/items/b6c3ffea060bcd237478
  4. https://qiita.com/copei/items/710a2d05114ec1637268
  5. https://qiita.com/KosukeJin/items/bb0daaed9f058439e225<

DDR用ワイヤレスヘッドフォンシステム

DDR用ワイヤレスヘッドフォンシステム

経緯

先日、友達のもずさんと映画を見に行って、その帰りにRoundOneに寄った際、以前作った「DDR用ワイヤレスヘッドフォンシステム」を使ってもらったのです。

すると、「Twitterに書いても良いですか」、との確認が来たので、「むしろ歓迎します」と喰い気味に許可したら、こんな感じでつぶやいてもらえました。

で、嬉しい事に、やぎさんから「材料や制作過程についてお伺いしても宜しいでしょうか?」とのお言葉を頂いたので、レスでお伝えしたのです。

が、やはり140文字では伝わりきれて居ないと思うので、写真も増やして説明をしようと思った次第です。

材料

これは既にTwitterに記載したとおりですが、ここにも記載します。

  • MDR-IF245RK
  • TASCOM MiniSTUDIO
  • 12VDCのバッテリー(単三電池8本)
  • プラグ
  • 集音機
  • 磁石つきクリップ
  • 100円ショップで買える引き出し
  • 滑り止めのシート
  • 携帯電話用のモバイルバッテリー
  • マジックテープ

この中で一番高いのはTASCOM MiniSTUDIOで、集音機で拾った音をワイヤレスヘッドフォンへの入力にするために使っています。

次に高いのはMDR-IF245RKで、ワイヤレスヘッドフォンです。

欠点がいくつかあるのであげておきます。

  • 真後ろを向いたとき、通信できないので音が止まる。
  • イヤーパッドが汗でぬれる
  • 縦方向の範囲が狭いので、光を発する部品が頭のある方向に向くよう傾斜をつけてあげるのがよい。
  • 連続で使うと半日程度でバッテリーが切れる
  • オープン式なので周囲の音が入ってくる。つまり周囲の音が大きいと、サウンドセパレータとしての能力が十全に発揮されない。

安いけれども重要なのが、集音機と磁石付きクリップです。

これがあるおかげで、筐体に傷をつけることなくスピーカー近傍に週音機を配置できます。

ただし、Xの筐体ではスピーカー近傍に金属部があるため問題ないのですが、A20の筐体では金属部がむき出しになっていないため、取り付けることができません。

吸盤にするなどの改善策が必要なのです。

仕組み

                                         電池ボックス(単三電池8本)
                                                  |
集音機----------TASCOM MiniSTUDIO<----------MDR-IF245RK(トランスミッタ)----------ヘッドフォン
                      |
                 充電用モバイルバッテリー

画像

f:id:wd4096:20190830010631j:plain

集音器です。

磁石付きのクリップで足を挟み込んでいます。

 

f:id:wd4096:20190830010546j:plain

ワイヤレスヘッドフォンのトランスミッターの背面部です。

音声ケーブルと、電池ボックスからの電源コードを接続しています。

 

f:id:wd4096:20190830010612j:plain

TASCOMのボリューム調整はこんな感じです。

マイク側の音量はMIN近くまで落として、ヘッドフォン側のボリュームをMAX近くまで上げています。

ヘッドフォン側は集音器に繋がっています。

つまり、「大きく入れて小さく出す」調整です。

どこかで読んだのですが、この方が音が綺麗になるとのこと。

なお、筐体の音が大きい場合はヘッドフォン側のボリュームを更に絞る必要があります。

なので、使う場合は自分のホームに合わせて調整するのが吉です。

 

 

f:id:wd4096:20190830010621j:plain

TASCOM前面の結線です。

マイク端子に集音器を接続、ヘッドフォン端子をヘッドフォンのトランスミッターの入力へつないでいます。

 

f:id:wd4096:20190830010535j:plain

電池ボックスです。

単三電池8本で、12Vの電圧を得ています。

なお、購入した電池ボックスのプラグはヘッドフォンのトランスミッターとは規格が異なっていたので、

プラグは形状が合うものを買ってきて半田付けしました。

 

f:id:wd4096:20190830010600j:plain

TASCOM用のバッテリーとして、携帯電話用のバッテリーを使っています。

使い方

集音器を筐体の右上スピーカー近傍へ貼り付け。

本体はやや全面が浮き上がる方向にして置きます。

運搬に使っている手提げ袋を丸めて突っ込むことが多いです。

電池ボックスと携帯電話用バッテリーの電源を入れます。

ヘッドフォンの電源を入れます。

ヘッドフォンのボリュームを調整します。

 

なお、連続で使用した場合、半日くらいでヘッドフォンのバッテリーが切れます。

こまめな充電と、長時間利用時の引き上げ時刻は大切だと思います。

最後に

不明点や実際に使ってみた感想などあればよろしくお願いいたします。

 

「"」で括られた範囲内の「,」を無視するCSVファイルの列数取得用関数を作成する

[Excel VBA]「"」で括られた範囲内の「,」を無視するCSVファイルの列数取得用関数を作成する

発端

発端は以下の記事。

いつものごとく安請け合いしたのでコーディング。

完成画像

f:id:wd4096:20190627204326p:plain

「"」に括られた「,」が列数のカウントから除外されているのが分かると思います。

コード

例によって?コード内のコメントで分かるように書いていますので、コメント以外の解説は省きます。

Option Explicit

Public Function pfCountColomns(strInput As String, strDelim1 As String, strDelim2 As String) As Long
'--------------------------------------------------------------------------------
'列数カウント関数
'--------------------------------------------------------------------------------
'引数
' strInput As String   :分割対象の文字列
' strDelim1 As String  :区切り文字1。区切り文字1同士で囲まれた範囲では区切り文字2を無視する
' strDelim2 As String  :区切り文字2
'戻り値
' 区切り文字で区切ったときの列数
'--------------------------------------------------------------------------------
Dim lngPos As Long      '文字列の検査位置
Dim isInner As Boolean  '優先度の高い区切り文字の中にいるかどうかフラグ
Dim lngCol As Long      '列数
Dim lngLen As Long      '対象文字列の文字通

    '対象文字列の長さ取得
    lngLen = Len(strInput)
    lngPos = 1
    isInner = False
    lngCol = 1

    '文字列がなくなるあまでループ
    Do While (lngPos <= lngLen)
        '現在位置の文字で分岐
        Select Case Mid(strInput, lngPos, 1)
            '区切り文字1
            Case strDelim1
                If isInner Then
                    '区切り文字1の中に居る場合、区切り文字1の終了
                    isInner = False
                Else
                    '区切り文字1の外に居る場合、区切り文字1の開始
                    isInner = True
                End If
                
            '区切り文字2
            Case strDelim2
                If isInner Then
                    '区切り文字1の中に居る場合、スキップ
                Else
                    '区切り文字1の外に居る場合、列数+1
                    lngCol = lngCol + 1
                End If
        End Select
        
        '検査位置を進める
        lngPos = lngPos + 1
    Loop

    '区切り文字1の中に居る場合、構文エラー
    If isInner Then
        MsgBox "構文エラー"
    End If

    '戻り値設定
    pfCountColomns = lngCol
End Function

反省点

「区切り文字1」と「区切り文字2」は順序を逆にして、かつ、2個目の区切り文字を「省略可能」にするべきでした。

というのも、「"」を無視したいな、という要望がきたときに呼び出し痔の引数指定だけで対応できるからです。

ちなみに、引数を省略できるようにするためには「optional」接頭辞を付与しますが、今回は説明を省略します。

ともあれ二宮さん。ふぁいと、おー、なのですよ。

多段階選択リストを用いたテストデータ作成




[Excel Worksheet関数]多段階選択リストを用いたテストデータ作成

発端

どのツィートかは忘れましたが、2つのリストの複数列を比較して差異のある行だけを抽出したいという話題がありました。

結局その話題には間に合わなかったのですが、その際、掲題の通り、多段階選択リストについてテストデータをランダム生成するWorksheet関数の使いかたを思いつきましたので、備忘もかねて書いておきます。

数式

まず、今回のケースでは、リストの選択肢を名前付き範囲設定をしておいてから使う方法を採りました。

1段目:=INDEX(種類,RANDBETWEEN(1,COLUMNS(種類)))

2段目:=INDEX(INDIRECT(B2),RANDBETWEEN(1,ROWS(INDIRECT(B2))))

f:id:wd4096:20190624040702p:plain

軽く説明すると。

1段目の数式で、「種類」リストからランダムに1個文字列を取り出し、

2段目の数式で、1段目の文字列を元にしたリストからランダムに1個文字列を取り出しています。

以下、名前付き範囲の設定状況です。

f:id:wd4096:20190624040605p:plain

f:id:wd4096:20190624040624p:plain

f:id:wd4096:20190624040636p:plain

f:id:wd4096:20190624040650p:plain

まとめ

既に同じような方法でテストデータを作成している方も居るかもしれませんが、もしもお役に立てたら幸いです。

まあ、似たような結論になりそうな気はしますが。

なお、本数式には改善の余地が多分にあります。

3段階のリストにした場合、もしくはデータ量が多い時、名前付き範囲の定義を不要にする工夫が必要になってくるはずですし、重複を予防するロジックも必要に応じて付け加える必要がります。

まあ、このくらいで。

置換処理を自作してみる


[ExcelVBA]置換処理を自作してみる

発端

以下のツィートに対して私が返信したレスから始まって、@umesansansan さんへのレスに私が返したレスに対して、@koto218 さんが返したレスが発端です。

中略

コンピューター上での置換処理について、原始的なものを作りましょう、

という、説明資料的なものを作るお約束をしたので作ってみたわけです。

組みあがった関数の動作

実際に組みあがった関数を使った実行例を載せておきます。

大体VBAのreplace関数の「オプションを指定しない場合の」動作に近いです。

実行結果

実行結果

基本的な考え方

ツィートした以下文章が、基本的な考え方です。

「置換後文字列を配置するメモリを確保しておいて、パターンマッチするまでデータ転送・マッチしたら置換後文字列を配置、の繰り返しが妥当かと。」

 

コンピューターで扱う文字列がメモリ上に配置されるとき、あるメモリの番地から順番に文字が格納されます。

この文字列の中の部分文字列を別の文字列で置換する場合、置換前後で文字列長が異なる場合に、単純な置換ができません。

なぜなら、ツィートしたとおり、「単純に「見つけた位置に代入」すると、後方の文字が上書きされたり、置換されずに残る文字が生まれます。」からです。

ではどうするか、というときに、現在のようにPCのメモリが潤沢な環境であるならば、「置換後の文字列をすべて保管する領域を確保して置換後文字列を編集する」のが妥当な線だと考えます。

このとき問題になるのが、「確保する領域のサイズが最初は分からない」ことです。

置換前後の文字列長が等しい場合は、置換前の文字列と同じ長さになることが保障されているので問題はないですが、そうでない場合、領域確保前に、必要な領域のサイズを確認する必要があります。

ここで、確保した領域が実際の置換後文字数よりも少ない場合、VBAでは「インデックスの範囲外です」エラーになりますし、

Cだと「バッファオーバーフロー

MFCだと「バッファオーバーラン」の障害を引き起こしてしまいます。

ここまでがメモリ確保です。

 

次に、パターンマッチですが、単純に1バイトずつ比較し、検索文字列がすべてマッチした場合に「一致した」とみなし、置換後文字列を、確保したメモリ領域に追加します。

それ以外の文字列については「一致しなかった」とみなして、そのままの文字列を確保したメモリ領域に追加します。

これを、検索対象の文字列がなくなるまで繰り返します。

コード

以下が今回作成したコードになります。

なお、置換後文字列の文字数を出す処理と、実際の置換ロジックは、少し工夫をすれば1つの関数にまとめることが可能です。

ただし、今回は原始的な置換ロジックの説明がメインであるため、2つの関数に分けています。

Option Explicit

'--------------------------------------------------------------------------------
'関数名:myReplace
'引数:
'strExp:対象の文字列
'strFind:検索するサブ文字列
'strRep:置換後の文字列
'戻り値:
'strExp の長さがゼロ:長さがゼロの文字列 ("")
'strExp が Null :エラー。
'「strfind」 の長さがゼロ:「strExp」のコピー
'「strRep」 の長さがゼロ:すべての「strFind」が削除された「strExp」のコピー。
'
'参考:以下の、VBAに用意された既存関数の外部仕様を参考にコーディング
'目的は「原始的な置換ロジックのご説明」なので、必須でない引数は省略
'Replace(式、 find、 replace、[ start, [ count, [ compare ]])
'--------------------------------------------------------------------------------
Function myReplace(strExp As String, strFind As String, strRep As String) As String
    'strExpのNull検査
    If IsNull(strExp) Then
        'Nullの使い方が不正です
        Err.Raise 94
    End If
    
    'strExpの長さ0検査
    If Len(strExp) = 0 Then
        myReplace = ""
        Exit Function
    End If
    
    'strFindの長さ0検査
    If Len(strFind) = 0 Then
        myReplace = strExp
        Exit Function
    End If
    
    'strRepの長さ0検査
    '検査不要。今回作成するロジックでは置換後文字列長は0でもかまわないため。
    
    '置換後のバイト数を確認
    Dim lngByte As Long
    lngByte = getReplacedBytes(strExp, strFind, strRep)
    
    '領域確保
    Dim byteTemp() As Byte
    ReDim byteTemp(lngByte + 1)
    
    '置換実行
    Call getReplacedString(strExp, strFind, strRep, byteTemp)
    
    '戻り値に設定
    myReplace = CStr(byteTemp)
End Function

Function getReplacedBytes(strExp As String, strFind As String, strRep As String) As Long
'--------------------------------------------------------------------------------
'関数名:getReplacedBytes
'引数:
'strExp:対象の文字列
'strFind:検索するサブ文字列
'strRep:置換後の文字列
'戻り値:
' 置換後の全体文字列長
'--------------------------------------------------------------------------------
Dim lngLen As Long      '置換後の文字列長
Dim lngSub As Long      '検索文字列中のマッチング文字数
Dim lngPos As Long      '検索対象文字列中の検索位置
Dim lngWhole As Long    '検索対象文字列全体のバイト長

    '初期化
    lngLen = 0
    lngSub = 0
    lngPos = 1
    lngWhole = LenB(strExp)
    
    '対象文字列を検査し終えるまでループ
    Do Until lngPos > lngWhole
        If MidB(strExp, lngPos, 1) <> MidB(strFind, lngSub + 1, 1) Then
            'マッチングしていない場合
            '置換後の全体文字列長に、これまでマッチした文字列長+1を加算
            lngLen = lngLen + lngSub + 1
            
            '検索文字列中のマッチング文字数をリセット
            lngSub = 0
        Else
            'マッチングしている場合
            If lngSub = LenB(strFind) - 1 Then
                'マッチした文字数=検索文字列長-1(マッチングの終了)
                '置換後の全体文字列長に、「置換後の文字列」の長さを加算
                lngLen = lngLen + LenB(strRep)
                'マッチング文字数をリセット
                lngSub = 0
            Else
                'マッチング終了していない場合
                'マッチング文字数+1
                lngSub = lngSub + 1
            End If
        End If
        
        '検索位置を勧める
        lngPos = lngPos + 1
    Loop
    
    '置換後の全体文字列長に、これまでマッチした文字列長を加算
    '補足:検索対象の文字列の最後尾に、検索文字列が途中まで入っているケースへの対応
    lngLen = lngLen + lngSub
    
    '戻り値設定
    getReplacedBytes = lngLen
End Function

Sub getReplacedString(strExp As String, strFind As String, strRep As String, byteRet() As Byte)
'--------------------------------------------------------------------------------
'関数名:getReplacedString
'引数:
'strExp:対象の文字列
'strFind:検索するサブ文字列
'strRep:置換後の文字列
'byteRet():置換後の文字列(byte型配列)
'--------------------------------------------------------------------------------
Dim lngSub As Long      '検索文字列中のマッチング文字数
Dim lngPos As Long      '検索対象文字列中の検索位置
Dim lngDes As Long      '置換後全体文字列中の位置
Dim lngWhole As Long    '検索対象文字列全体のバイト長
Dim lngIdx As Long

    '初期化
    lngSub = 0
    lngPos = 1
    lngDes = 0
    lngWhole = LenB(strExp)
    
    '対象文字列を検査し終えるまでループ
    Do Until lngPos > lngWhole
        If MidB(strExp, lngPos, 1) <> MidB(strFind, lngSub + 1, 1) Then
            'マッチングしていない場合
            '置換後の全体文字列に、これまでマッチした文字列長+1を追加
            For lngIdx = 0 To lngSub
                byteRet(lngDes) = AscB(MidB(strExp, lngPos - lngSub + lngIdx))
                lngDes = lngDes + 1
            Next
            
            '検索文字列中のマッチング文字数をリセット
            lngSub = 0
        Else
            'マッチングしている場合
            If lngSub = LenB(strFind) - 1 Then
                'マッチした文字数=検索文字列長-1(マッチングの終了)
                '置換後の全体文字列長に、「置換後の文字列」を追加
                
                For lngIdx = 1 To LenB(strRep)
                    byteRet(lngDes) = AscB(MidB(strRep, lngIdx, 1))
                    lngDes = lngDes + 1
                Next
                
                'マッチング文字数をリセット
                lngSub = 0
            Else
                'マッチング終了していない場合
                'マッチング文字数+1
                lngSub = lngSub + 1
            End If
        End If
        
        '検索位置を勧める
        lngPos = lngPos + 1
    Loop
    
    '置換後の全体文字列長に、これまでマッチした文字列を追加
    '補足:検索対象の文字列の最後尾に、検索文字列が途中まで入っているケースへの対応
    For lngIdx = 1 To lngSub
        byteRet(lngDes) = AscB(MidB(strFind, lngIdx, 1))
        lngDes = lngDes + 1
    Next
End Sub

コードの組み始めについて

このあたりは個人の好みなのですが、私の場合はコメント文でロジックを記載してから肉付けをします。

なので、最初に下図のようなコメントだけのコードが出来上がります。

この状態からだと様々な言語でコーディングを開始できるため、結構重宝します。

コーディング開始

コーディング開始

追記 2019/6/18 2:26

ちなみに。

このロジックを読んで「デリートインサートで行くと思う」と言う方が居たとします。

その場合、考慮が足りないとしか言いようがないです。

ロジックの組み方にもよりますが、特定の文字列の中から特定の文字列をデリートするのに必要なデータの移動回数は、特定の文字列以降の文字数に等しいです。

そして、特定の文字列の中に特定の文字列を挿入する場合に必要なデータの移動回数は、挿入位置以降の文字数に等しく、かつ、この場合領域の拡張が必要です。

すると、複数個の文字が検索でヒットする場合、その文字が見つかった箇所以降の文字数×2回のデータ移動が発生します。

検索対象の文字列長が長ければ長い程この傾向は顕著になります。

例えば、検索対象の文字列長が10,000文字であり、その中に10個の検索文字列が一様な密度で分散しているとします。

その場合、デリートインサートで移動されるデータの数は、(9,000+1,000)*5*2=100,000個になります。

それに対して、前述のロジックで処理した場合、データの移動はワーク領域への転送と、戻り値への設定の2回を検索対象の文字列長繰り返すのみですので、10,000*2=20,000個になります。

この時点で必要なデータ移動回数は5倍です。

当然のことですが、デリートインサートで置換を行った場合、ヒットするキーワード数に比例してデータ移動回数が増えます。

ヒットするキーワード数が1000個だった場合はどうでしょうか。

本記事のロジックと比較して、単純計算で500倍のデータ移動が発生する事になります。

移動対象のデータが配置されているのがメモリなのかSSDなのかHDDなのかによってレスポンスはかなり変わってきますが、ケースによって致命的にレスポンスが悪くなるロジックは、採用されないと思うのです。

図解した方が分かり易かったかも知れませんが、「文字列の削除」や「文字列の挿入」にはそれなりにコストがかかります。

内部でどういう動作になっているかイメージできない方は、データがアドレスに割り当てられているイメージが持てていないのかも知れないですね。

なお、実際にこれらのコードをコンパイルした場合、その速度差は500倍まではいかないはずです。

なぜなら、マシン語には「ブロック転送命令」(複数のデータを一度に別のアドレスに転送する命令)があるからです。

8bit時代にもあったから64bitでもあると思ってぐぐったら普通にありました。

それでも、500倍まではいかないだけであって、非効率的であることに変わりはないのですけど。

異なる本文で一斉メールするVBA

[Excel VBA]異なる本文で一斉メールするVBA

公開の発端

こちら。ことりさんなら多分、時間があれば自分でVBA組んでたんだろうなあ、と思うのです。

しかも既に作業は終わってるので今更感が大きいですが、折角なので載せておこうかと。

作成経緯

件名の通り、異なる本文で複数の宛先に一斉メールするためのVBAです。

元々は同人カードゲームの通販対応用に作ったVBAで、現在は大学のOB会の案内で主に使っています。

テンプレートの中に各人毎に異なる内容を埋め込めるので、「前回の出欠」なども入れ込めて便利です。

概要

ユーザーが実行できるアクションは以下の通りです。

・テンプレートシートの追加・編集

・対象宛先の選択

・プレビュー

・一括送信

メールエンジンはOutlookに依存しています。

送信はSMTPアカウントを持っている事が前提となります。

使用方法

◎概要		
	テンプレートに名簿の内容を差し込んでメール送信するツールです。	
	使用イメージとしては、Word の差し込み印刷に似ています。	
	一括同報や、相手ごとに内容をこまめに変更して送信したりする場合など、利用できると思います。	
		
◎環境		
	Microsoft Excel および Microsoft Outlook がインストールされていること	
	メール作成・送信時はOutlook が起動されていることが必要になります。	
		
◎テンプレートの選択		
	「使用テンプレート」を選択します。ここで選択したシートに記載されているテンプレートに対して、名簿の情報を差し込みます。	
	ここで選択したシートの事を、本説明では、「[テンプレート]シート」と記載します。	

◎プレビュー	
	用途:メールを送信前に確認したいときに使います。
	1 送信したい行の「選択」列にチェックを入れます。
	2 「プレビュー」ボタンをクリックします。
	3 すると、選択した行の内容を [テンプレート] シートに埋め込んだ内容でメールが表示されます
◎複数宛先送信		
	複数の宛先に、送信内容を事前確認せず送信したい場合。	
	1 送信したい行の「選択」列にチェックを入れます。	
	2 「一括送信」ボタンをクリックします。	
	3 選択した行の内容を[テンプレート]シートに埋め込んだ内容で、メールが自動送信されます	
		
◎名簿、テンプレートのメンテナンス		
	▼[名簿]シート	
		タイトル行(3行目の行)は、列を自由に追加削除できます。
		ただし、1列目から表の最後の列まで、空白セルが無いようにしてください。
		空白セルでタイトル行の終わりを検知していますので、タイトルの読み込みが止まってしまいます。
		
		応用例としましては、「職務経歴」や「スキル」などの列を追加して、営業先に職務経歴を送るメールを作成するのもありだと思います。
		
	▼[テンプレート]シート	
		メールの内容を記載するシートです。
		メール作成時に名簿の内容を反映したいキーワードを「%%」で括って記載します。
		ファイルを添付したい場合、[添付ファイル]と記載した行の2列目にフルパスを入力します。
		
		なお、シート名が[テンプレート]であればよいので、複数のテンプレートを作成しておき、シート名変更で随時切り替えるのが便利と思います。

画面

「名簿」シート

f:id:wd4096:20190510224307p:plain

テンプレートシート(例)

f:id:wd4096:20190510224331p:plain

メール例

f:id:wd4096:20190510224349p:plain

コード

Thisworkbook

テンプレートシートの名前をリストボックスに追加するコードです。

Option Explicit

Private Sub Workbook_Open()
'入力規則設定
Const MAX_COL As Long = 1000    'キーワードを検索する右端のセル
Dim arySheet() As String
Dim objSheet As Worksheet
Dim lngCol As Long

    'テンプレートを選択するセルをキーワードで探す
    lngCol = getColumn("使用テンプレート", "名簿", 1)
    
    '最大列数に到達していない場合、キーワードは見つかったとみなす
    If lngCol <> MAX_COL Then
        lngCol = lngCol + 1
        ReDim Preserve arySheet(0)
        For Each objSheet In ThisWorkbook.Sheets
            'シート名に「テンプレート」の文字が入っているシートだけをテンプレートとして扱う
            If InStr(objSheet.Name, "テンプレート") > 0 Then
                '配列変数の配列を1増やす
                ReDim Preserve arySheet(UBound(arySheet) + 1)
                
                'シート名設定
                arySheet(UBound(arySheet) - 1) = objSheet.Name
            End If
        Next
    
        '設定先のセルを選択する
        ThisWorkbook.Sheets("名簿").Activate
        ThisWorkbook.Sheets("名簿").Cells(1, lngCol).Select
        
        If UBound(arySheet) = 0 Then
            '対象が無い場合、入力規則をクリアする
            With Selection.Validation
                .Delete
            End With
        Else
            '対象がある場合、入力規則を設定する
            ReDim Preserve arySheet(UBound(arySheet) - 1)
            With Selection.Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=Chr(32) & Join(arySheet, ",") & Chr(32)
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .IMEMode = xlIMEModeNoControl
                .ShowInput = True
                .ShowError = True
            End With
        End If
    End If
End Sub

modMain.bas

プレビュー表示、メール一括送信のコードです。

もっと簡単にできる方法はあれこれあるので、参考になれば幸い程度です。

まずAccessがあるならすごく楽ですし、キーワードの右端を1000と決め打ちしているのも美しくないです。

あと、ぷち工夫として、チェックを入れるのにフォント「Marlett」を使っています。

このフォントだと、「a」が「チェック」を表す記号になるのですよね。

    Option Explicit

Const TITLE_ROW As Long = 3 'タイトル行

Public Sub pSubSendMail()
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        If ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a" Then
            Call pSubMakOrSendeMail(lngRow, True)
        End If
        lngRow = lngRow + 1
    Loop
End Sub

Public Sub pSubMakeMail()
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        If ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a" Then
            Call pSubMakOrSendeMail(lngRow, False)
        End If
        lngRow = lngRow + 1
    Loop
End Sub


Private Sub pSubMakOrSendeMail(lngTargetRow As Long, blnSend As Boolean)
'メール作成
'「名簿マスター」シートの選択行から情報を読み取り、
'「テンプレート」シートのテンプレートに従ってメールを作成する
Const MAX_COL As Long = 1000    'キーワードを検索する右端のセル
Dim objOutlook As Outlook.Application
Dim objMail As MailItem
Dim lngRow As Long
Dim lngCol As Long
Dim strTemp As String
Dim strTitle As String
Dim strValue As String
Dim vntTemp As Variant

Dim varRecipients As Variant
Dim lngIdx As Long

Dim strTemplate As String

    'テンプレートを選択するセルをキーワードで探す
    lngCol = getColumn("使用テンプレート", "名簿", 1)
    
    '最大列数に到達していない場合、キーワードは見つかったとみなす
    If lngCol <> MAX_COL Then
        strTemplate = Trim(ThisWorkbook.Sheets("名簿").Cells(1, lngCol + 1))
        
        'Outlookオブジェクト作成
        Set objOutlook = New Outlook.Application
        
        'メールアイテム作成
        Set objMail = objOutlook.CreateItem(olMailItem)
        
        '*** メールに項目を記載 ***
        '** ReplyTo **
        strTemp = ThisWorkbook.Sheets(strTemplate).Cells(1, 2)
        If strTemp <> "" Then
            varRecipients = Split(strTemp, ";")
            For lngIdx = 0 To UBound(varRecipients)
                objMail.ReplyRecipients.Add varRecipients(lngIdx)
            Next
        End If
        
        '** To **
        objMail.To = ThisWorkbook.Sheets("名簿").Cells(lngTargetRow, getCol("電子メール アドレス"))
        
        '** 件名 **
        objMail.Subject = ThisWorkbook.Sheets(strTemplate).Cells(2, 2)
        
        '** 本文 **
        '* テンプレート読み込み *
        '%END%になるまで読み込む
        lngRow = 3
        strTemp = ""
        Do While (ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2) <> "%END%")
            strTemp = strTemp & ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2) & vbCrLf
            lngRow = lngRow + 1
        Loop
        
        '* キーワード置換 *
        With ThisWorkbook.Sheets("名簿")
            lngCol = 1
            Do Until .Cells(TITLE_ROW, lngCol) = ""
                strTitle = .Cells(TITLE_ROW, lngCol)
                strValue = .Cells(lngTargetRow, lngCol)
                strTemp = Replace(strTemp, "%" & strTitle & "%", strValue)
                lngCol = lngCol + 1
            Loop
        End With
                
        objMail.Body = strTemp
        
        
        '** 添付ファイルを添付 **
        '* 添付ファイルのパスを記載した行を探す *
        Do While (ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 1) <> "添付ファイル")
            lngRow = lngRow + 1
        Loop
        strTemp = ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2)
        
        '* 添付ファイル追加 *
        If strTemp <> "" Then
            vntTemp = Split(strTemp, ",")
            For lngIdx = 0 To UBound(vntTemp)
                objMail.Attachments.Add (vntTemp(lngIdx))
            Next
        End If
        
        'メール表示
        objMail.Display
        If blnSend Then
            objMail.Send
        End If
    End If
End Sub

Function getCol(strKeyword As String) As Long
    getCol = 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(TITLE_ROW, getCol) = "") Or (ThisWorkbook.Sheets("名簿").Cells(TITLE_ROW, getCol) = strKeyword)
        getCol = getCol + 1
    Loop
End Function

Sub clearCheckAll()
'Noがある行のチェックをクリアする
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = ""
        lngRow = lngRow + 1
    Loop
End Sub

Sub setCheckAll()
'Noがある行のチェックをセットする
Dim lngRow As Long

    lngRow = TITLE_ROW + 1
    Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
        ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a"
        lngRow = lngRow + 1
    Loop
End Sub

Sub clearCheck()
'Noがある行のチェックをクリアする
Dim lngRow As Long
Dim lngOldRow As Long
Dim objRange As Range
    
    lngOldRow = 0
    For Each objRange In Selection
        lngRow = objRange.Row
        If lngOldRow <> lngRow Then
            If lngRow > TITLE_ROW And ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) <> "" Then
                ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = ""
            End If
            lngOldRow = lngRow
        End If
    Next
End Sub

Sub setCheck()
'Noがある行のチェックをセットする
Dim lngRow As Long
Dim lngOldRow As Long
Dim objRange As Range
    
    lngOldRow = 0
    For Each objRange In Selection
        lngRow = objRange.Row
        If lngOldRow <> lngRow Then
            If lngRow > TITLE_ROW And ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) <> "" Then
                ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a"
            End If
            lngOldRow = lngRow
        End If
    Next
End Sub

Function getColumn(strKeyword As String, strSheet As String, lngRow As Long) As Long
'入力規則設定
Const MAX_COL As Long = 1000    'キーワードを検索する右端のセル
Dim lngCol As Long

    'キーワードで探す
    lngCol = 1
    Do Until ThisWorkbook.Sheets(strSheet).Cells(lngRow, lngCol) = strKeyword Or lngCol > MAX_COL
        lngCol = lngCol + 1
    Loop
    
    getColumn = lngCol
End Function

2019/05/11 0:19追記

添付ファイルを相手先ごとに変更するコード出来ました。さっきまでツイッター触ってたので実質10分位。やはり小工数だったのです。

変更箇所だけを掲載しておきます。

こうして見てみると、キーワード置換は関数化するべきですね。

明日もそこそこ早いので今日はそろそろ寝るのです。

        '* 添付ファイル追加 *
        If strTemp <> "" Then
            '添付ファイルにキーワードを使えるようにする
            If Left(strTemp, 1) = "%" Then
                '* キーワード置換 *
                With ThisWorkbook.Sheets("名簿")
                    lngCol = 1
                    Do Until .Cells(TITLE_ROW, lngCol) = ""
                        strTitle = .Cells(TITLE_ROW, lngCol)
                        strValue = .Cells(lngTargetRow, lngCol)
                        strTemp = Replace(strTemp, "%" & strTitle & "%", strValue)
                        lngCol = lngCol + 1
                    Loop
                End With
            End If

            vntTemp = Split(strTemp, ",")
            For lngIdx = 0 To UBound(vntTemp)
                objMail.Attachments.Add (vntTemp(lngIdx))
            Next
        End If

グループの折り畳み

[Excel VBA]グループの折り畳み

発端

発端はばっちりさんのツィートからです。

動作確認してみると、この「ShowLevels」ってメソッド、アウトラインで表示されている数字ボタンを押したときと同じ動作でした。

なので、アクティブセルの行がグループ化されてる時に、というニーズには合わないのです。

動画

f:id:wd4096:20190424052116g:plain

コード/解説

「psToggle」を呼び出すと、アクティブセルについてグループを畳んだり開いたりします。

アウトライン表示の折り畳みは単純に行・列を非表示にしているだけなので、対象範囲を抽出後、隠せばOKなのです。

rangeオブジェクトを確認すると、OutlineLevelというプロパティが見つかりましたので、これを利用してコードを組みました。

なお、アウトライン表示にはオプションがあって、集計行の位置を、詳細行の上下いずれにするかを選べるのです。

どちらを選んだかはOutlineオプションの「SummaryRow」プロパティで判定できるので、これで分岐して表示します。

なお、今回、「グループ化されている行」をすべてのレベル一斉に畳むようにしましたが、Excelのリボンについているボタンと同じ動作にする場合は、上下への検索条件を「1以上」から「ActivecellのOutlineLevelと同じ」に変更する必要があります。

大きな修正にはなりませんので、あとはお好みでどうぞ、なのです。

Option Explicit

Sub psToggle()
    '選択セルの行がグループ化されている場合、閉じる
    If Rows(ActiveCell.Row).OutlineLevel > 1 Then
        '上へ向かって探索、下へ向かって探索、隠す
        Range(Rows(search2Up(ActiveCell)), Rows(search2Down(ActiveCell))).Hidden = True
    Else
        Select Case ActiveSheet.Outline.SummaryRow
            Case 0
                '集計行は詳細行の上
                '1行下が隠れていて、かつ、Outlineレベルが2以上であるとき、
                '折りたたまれていると判定して、開く
                If (Rows(ActiveCell.Row + 1).OutlineLevel < 1048576) And (Rows(ActiveCell.Row + 1).Hidden) Then
                    '下へ向かって探索、表示する
                    Range(Rows(ActiveCell.Row), Rows(search2Down(ActiveCell))).Hidden = False
                End If
            Case 1
                '集計行は詳細行の下
                '1行上が隠れていて、かつ、Outlineレベルが2以上であるとき、
                '折りたたまれていると判定して、開く
                If (Rows(ActiveCell.Row - 1).OutlineLevel > 1) And (Rows(ActiveCell.Row - 1).Hidden) Then
                    '上へ向かって探索、表示する
                    Range(Rows(search2Up(ActiveCell)), Rows(ActiveCell.Row)).Hidden = False
                End If
        End Select
    End If
End Sub

Function search2Up(objRange As Range) As Long
Dim lngFirst As Long

    '上へ向かって探索
    lngFirst = objRange.Row
    If lngFirst - 1 > 1 Then
        Do While (lngFirst - 1 > 1) And (Rows(lngFirst - 1).OutlineLevel > 1)
            lngFirst = lngFirst - 1
        Loop
    End If
    
    search2Up = lngFirst
End Function

Function search2Down(objRange As Range) As Long
Dim lngLast As Long

    '下へ向かって探索
    lngLast = objRange.Row
    If lngLast + 1 < 1048576 Then
        Do While (lngLast + 1 < 1048576) And (Rows(lngLast + 1).OutlineLevel > 1)
            lngLast = lngLast + 1
        Loop
    End If
    
    search2Down = lngLast
End Function