画面サイズに応じて改行要否をCSSでコントロールしてみた

発端

解決策

CSSを使って、画面サイズが600pxより小さい場合はbr要素を消すCSSを書きました。

以下、任意の文字列を入力できる動作確認ページです。

テストページ

前述のCSSはこの記事にも適用しています。

以下、改行の調整が上手くいっているのか、確認してみます。

改行テストの為、
読点(、
)毎に改行タグを挿入します。

スマートフォンで閲覧した場合に、
縦画面では改行が無効化され、
横画面では改行が有効になります。

画面の自動回転を有効にした状態で試してみると分かりやすいと思います。

顛末

以下、その後のやり取りです。

ローカルで作成したHTMLをリアルタイム公開してみた

発端

今回はon Businessなので発端は伏せておきます。

完成版動作

ローカルで編集した結果が、Webに公開したページに数秒後に適用されます。

ツイートには意識的に書くことを避けましたけど、これ、「VBAなどで動的生成したHTML」もリアルタイム公開できるってことなのですよね。

まだ検証していませんが、G Suiteは社外からの参照が可能なので、オンプレミス環境で動的生成したコンテンツをリアルタイム公開できることに繋がるのです。

会社でG Suiteを契約している場合に、社外の人間に見せたくない社内向けコンテンツを社外から参照できるので、このことのメリットはかなり大きいのです。

仕組み

  • 「Googleのバックアップと同期」でローカルのHTML出力先フォルダーをGoogle Driveに同期
  • GASでGoogle Drive上のHTMLファイルをHTMLコンテンツとして出力
  • Webアプリとして公開

上記3段階で公開しています。

意外と簡単ですね!

なお、G Suiteで同じことを行う場合、「Googleのバックアップと同期」は使えなくで、「ドライブファイルストリーム」を使う必要があります。

使わなくても済む方法があれば凄く助かるのですけど、ちょっと分からないのです。

実装

まず、「Googleのバックアップと同期」をダウンロード・インストールします。

ファイルへのアクセスと同期をどこからでも

インストール完了後、タスクトレイに雲のアイコンが表示されますので、ここから同期設定を行います。

 

f:id:wd4096:20200704104923p:plain

 

今回、C:\sessionのみ同期対象にしました。

同期された後、フォルダーに移動してフォルダーIDを確認します。

f:id:wd4096:20200704105700p:plain

 

URLの末尾にあるのがそれです。

今回の場合、「13JIkXUT4ZQ5-OLjmo_nMPPVT2immSCbC」がフォルダーIDです。

これは後程GASからフォルダを取得する際に必要になります。

 

次に、GASを追加します。

f:id:wd4096:20200704105428p:plain

 

function doGet() {
  var contents = DriveApp.getFolderById('13JIkXUT4ZQ5-OLjmo_nMPPVT2immSCbC')
.getFilesByName('test.html')
.next()
.getBlob()
.getDataAsString("sjis");
  return HtmlService.createHtmlOutput(contents);
}

getFolderByIDで指定しているのが先ほど取得したフォルダーIDです。

最後に、GASをWebコンテンツとして公開します。

f:id:wd4096:20200704110033p:plain

 

「公開」→「Webアプリケーションとして導入」

f:id:wd4096:20200704110155p:plain

 

「Project Version」は常に「New」を選択します。

「Execute the app as」は自分のGoogleアカウントを指定します。

ただ、ここはGoogle Driveにアクセスできるアカウントならどれでもいいのだと思います。

「Who has access to the app:」アクセス可能なメンバーを選びます。今回テストですので、自分だけをアクセス可能にしました。

「更新」ボタンをクリックすると、デプロイされ、以下のような画面が表示されます。

f:id:wd4096:20200704110600p:plain

 

「Curent web app URL」が公開するURLです。

最後に

CSSをまだ適用していないので、帰宅後適用する処理を入れます。

参考記事は以下の記事です。

GAS関連検索すると高確率でこの方の記事が出てくるので、足を向けて眠れないのです。

GASでWebページを作るときにHTMLとCSSを別ファイルに記述する方法

追記

CSSをファイルから読み込ませる機能を追加しましたので、ひとまずこれでこの記事の更新は終了です。

参考URLは前述の通り。

以下、結果だけを書きます。構成ファイルは3個です。

HTMLファイル

 

<!DOCTYPE html>
<html>
<head>
<base target="_top">
<link rel="stylesheet" href="test.css">
<style>
<?!= HtmlService.createHtmlOutput(DriveApp.getFolderById('13JIkXUT4ZQ5-OLjmo_nMPPVT2immSCbC').getFilesByName('test.css').next().getBlob().getDataAsString("sjis")).getContent(); ?>
</style>
</head>
<body>
<h1>fugafuga9</h1>
<p>テスト</p>
<table>
<tr><td class="td_not_null">1</td><td>4</td><td>7</td></tr>
<tr><td>2</td><td class="td_not_null">5</td><td>8</td></tr>
<tr><td>3</td><td>6</td><td class="td_not_null">9</td></tr>
</table>
</body>
</html>

CSSファイル

.td_not_null{
border:solid;
border-color:black;
}    

GASファイル

function doGet() {
  var contents = DriveApp.getFolderById('13JIkXUT4ZQ5-OLjmo_nMPPVT2immSCbC')
.getFilesByName('test.html')
.next()
.getBlob()
.getDataAsString("sjis");
  const htmlOutput=HtmlService.createTemplate(contents).evaluate();
  return htmlOutput;
}

結果について

概ね満足です。

これで、ローカルで作成したHTMLファイルとCSSファイルを、Google Driveの機能で同期を行えば公開可能になるのです。

また、お気づきかも知れませんが、今回のやり方だと、GASで公開した内容と、ローカルファイルが実現できる見た目が一致します。

したがって、オンプレミス環境用のファイルと、GAS用のファイルとで2パターン持つ必要がなくなるのです。

データを一元化できるというのは、継続したメンテナンスのコストが安くなる事につながるので、良い結果だったと思います。

G Suiteでの結果について

良好でした。

最初うまくいかなかった原因は、「アップロードされたファイルを自動でGoogleドキュメントに変換する」オプションが有効になっていたためでした。

このオプションが有効であるとき、HTMLファイルをアップロードすると自動でPDFファイルに変換されるというアレげな仕様だったのです。

真面目に初見殺しな仕様ですよねー。

まあ、道は開けたので、あとは横展開するだけですね。

オンプレミス環境で自動生成したHTMLファイルを自動公開する手段が出来たのって、かなり業務の幅が広がるはずなのです。

今度こそこの記事の更新は終わります。

「Excel補助マクロ」

発端

ばっちりさんのツイで、凄く昔に作った補助マクロ(VBA)の存在を思い出したのです。

で、折角だから公開してみようかと。

概要

下図にあるように、複数の機能をアドインするようになってます。

最初に作ったのは2000年前後で、機能をあれこれ足しながら使ってた記憶があるのですが、手元に残ってるのは2003年の日付になってました。

f:id:wd4096:20200530103047p:plain

 

コード

凄く昔のコードなので結構汚いと思うのです。

「AddInとしてメニューに追加する」コード、「実際に動作するコード」、ユーザーフォームで動作するコード×2で構成されます。

しかも、ぬるいことに、当時はモジュール名を変更する癖がついてなかったようです。おぬるいですね。

Module1

Option Explicit

Public Const cst_cbarMainMenu = "EXCEL補助マクロ"

Public Const cst_cbarMacro1 = "先頭へ(&1)"
Public Const cst_cbarMacro2 = "最後尾へ(&2)"
Public Const cst_cbarMacro3 = "小文字へ(&3)"
Public Const cst_cbarMacro4 = "大文字へ(&4)"
Public Const cst_cbarMacro5 = "半角へ(&5)"
Public Const cst_cbarMacro6 = "全角へ(&6)"
Public Const cst_cbarMacro7 = "文字数(&7)"
Public Const cst_cbarMacro8 = "バイト数(&8)"
Public Const cst_cbarMacro9 = "重複チェック(&9)"
Public Const cst_cbarMacro0 = "シート削除(&0)"
Public Const cst_cbarMacroQ = "再採番(&Q)"
Public Const cst_cbarMacroS = "シート移動(&S)"
Public Const cst_cbarMacroU = "&UnInstall"

Public Const cst_cbarOnAction1 = "GoTop"
Public Const cst_cbarOnAction2 = "GoBottom"
Public Const cst_cbarOnAction3 = "ToLower"
Public Const cst_cbarOnAction4 = "ToUpper"
Public Const cst_cbarOnAction5 = "ToASC"
Public Const cst_cbarOnAction6 = "ToJIS"
Public Const cst_cbarOnAction7 = "DispLen"
Public Const cst_cbarOnAction8 = "DispLenB"
Public Const cst_cbarOnAction9 = "CheckDupe"
Public Const cst_cbarOnAction0 = "SheetDel"
Public Const cst_cbarOnActionQ = "ReNumber"
Public Const cst_cbarOnActionS = "SheetJump"
Public Const cst_cbarOnActionU = "ExcelAssist_AddinUninstall"

Sub GoTop()
    Sheets(1).Activate
End Sub

Sub GoBottom()
'変数定義
    Dim nSheets As Long
'--------------------------------------------------------------------------------
    'シートの最後尾を取得
    nSheets = Sheets.Count
    
    'シートの最後尾に移動
    Sheets(nSheets).Activate
End Sub

Sub ToLower()
'小文字へ変換
'--------------------------------------------------------------------------------
'変数定義
    Dim sTemp   As String
    Dim oRange  As Range
'--------------------------------------------------------------------------------
    For Each oRange In Selection
        sTemp = oRange.Text
        sTemp = StrConv(sTemp, vbLowerCase)
        oRange.Value = sTemp
    Next
End Sub
Sub ToUpper()
'大文字へ変換
'--------------------------------------------------------------------------------
'変数定義
    Dim sTemp   As String
    Dim oRange  As Range
'--------------------------------------------------------------------------------
    For Each oRange In Selection
        sTemp = oRange.Text
        sTemp = StrConv(sTemp, vbUpperCase)
        oRange.Value = sTemp
    Next
End Sub
Sub ToASC()
'半角へ変換
'--------------------------------------------------------------------------------
'変数定義
    Dim sTemp   As String
    Dim oRange  As Range
'--------------------------------------------------------------------------------
    For Each oRange In Selection
        sTemp = oRange.Text
        sTemp = StrConv(sTemp, vbNarrow)
        oRange.Value = sTemp
    Next
End Sub
Sub ToJIS()
'全角へ変換
'--------------------------------------------------------------------------------
'変数定義
    Dim sTemp   As String
    Dim oRange  As Range
'--------------------------------------------------------------------------------
    For Each oRange In Selection
        sTemp = oRange.Text
        sTemp = StrConv(sTemp, vbWide)
        oRange.Value = sTemp
    Next
End Sub

Sub DispLen()
'指定範囲の文字数合算を表示
'--------------------------------------------------------------------------------
'変数定義
    Dim nLen    As Long
    Dim nSum    As Long
    Dim nMax    As Long
    Dim sTemp   As String
    Dim oRange  As Range
'--------------------------------------------------------------------------------
    nSum = 0
    nMax = 0
    For Each oRange In Selection
        sTemp = oRange.Text
        nLen = Len(sTemp)
        If nLen > nMax Then
            nMax = nLen
        End If
        nSum = nSum + nLen
    Next
    Call MyDisp("文字数合計=" & CStr(nSum) & Chr(13) & "文字数最大=" & CStr(nMax))
End Sub
Sub DispLenB()
'指定範囲の文字バイト数合算を表示
'--------------------------------------------------------------------------------
'変数定義
    Dim nLen    As Long
    Dim nSum    As Long
    Dim nMax    As Long
    Dim sTemp   As String
    Dim oRange  As Range
'--------------------------------------------------------------------------------
    nSum = 0
    nMax = 0
    For Each oRange In Selection
        sTemp = oRange.Text
        nLen = LenB(sTemp)
        If nLen > nMax Then
            nMax = nLen
        End If
        nSum = nSum + nLen
    Next
    Call MyDisp("バイト数合計=" & CStr(nSum) & Chr(13) & "バイト数最大=" & CStr(nMax))
End Sub

Sub CheckDupe()
'重複チェック
'--------------------------------------------------------------------------------
'変数定義
    Dim sTemp   As String
    Dim sTemp2  As String
    Dim oRange  As Range
    Dim oRange2 As Range
    Dim nCnt    As Long
    Dim sResult As String
    Dim bFlag   As Boolean
'--------------------------------------------------------------------------------
    bFlag = False
    sResult = ""
    For Each oRange In Selection
        sTemp = oRange.Text
        
        'ブランク文字列の場合重複判定は省略
        If sTemp <> "" Then
            nCnt = 0
            For Each oRange2 In Selection
                sTemp2 = oRange2.Text
                If sTemp = sTemp2 Then
                    nCnt = nCnt + 1
                End If
            Next
            If nCnt > 1 Then
                sResult = sResult & "、" & sTemp
                bFlag = True
            End If
        End If
    Next
    
    If bFlag = True Then
        Call MyDisp("重複文字列:" & Chr(13) & Mid(sResult, 2))
    Else
        Call MyDisp("重複文字列はありませんでした")
    End If
End Sub

Sub SheetDel()
    '現在のシートを削除する
    ActiveSheet.Delete
End Sub

Sub ReNumber()
'--------------------------------------------------------------------------------
'再採番
'--------------------------------------------------------------------------------
'変数定義
    Dim sTemp   As String
    Dim sChar   As String
    Dim sHeader As String
    Dim sSEQ    As String
    Dim sFooter As String
    Dim oRange  As Range
    Dim nCnt    As Long
    Dim nPos    As Long
    
    Dim bFlag   As Boolean
'--------------------------------------------------------------------------------
    bFlag = False
    
    For Each oRange In Selection
        sTemp = oRange.Text
        If sTemp <> "" Then
            If bFlag = True Then
                nCnt = nCnt + 1
                sTemp = sHeader & Trim(CStr(nCnt)) & sFooter
                oRange.Value = sTemp
            Else
                nCnt = 0
                sHeader = ""
                sSEQ = ""
                sFooter = ""
                nPos = Len(sTemp)
                
                'フッタ作成
                Do Until nPos = 0
                    sChar = Mid(sTemp, nPos, 1)
                    If IsNumeric(sChar) = True Then
                        Exit Do
                    End If
                    sFooter = sChar & sFooter
                    nPos = nPos - 1
                Loop
                
                '連番初期値取得
                Do Until nPos = 0
                    sChar = Mid(sTemp, nPos, 1)
                    If IsNumeric(sChar) = False Then
                        Exit Do
                    End If
                    sSEQ = sChar & sSEQ
                    nPos = nPos - 1
                Loop
                
                '連番が有効なら採番開始
                If sSEQ <> "" Then
                    bFlag = True
                    nCnt = CLng(sSEQ)
                    
                    'ヘッダ取得
                    If nPos > 0 Then
                        sHeader = Left(sTemp, nPos)
                    End If
                End If
            End If
        End If
    Next
End Sub

Sub SheetJump()
    frmSheets.Show
End Sub

Private Sub MyDisp(strMessage As String)
'メッセージ表示
    frmDisp.txtMessage.Text = strMessage
    frmDisp.Show
    frmDisp.Repaint
    DoEvents
End Sub

'アドインメニューが存在するか確認
Public Function bExistThisAddinMenu(strMacro As String) As Boolean
    On Error Resume Next
    bExistThisAddinMenu = True
    If Application.CommandBars(cst_cbarMainMenu).Controls.Count = 0 Then
        bExistThisAddinMenu = False
'        If Application.CommandBars(cst_cbarMainMenu).Controls(strMacro).Caption = "" Then
'            '存在しない場合、RESUME NEXTにより下の文が実行される
'            bExistThisAddinMenu = False
'        End If
    End If
End Function


'アドインのアンインストール
Sub ExcelAssist_AddinUninstall()
    Dim ain As AddIn
    
    'メニューバー消去
    Application.CommandBars(cst_cbarMainMenu).Delete
    For Each ain In Application.AddIns
        If ain.Name = cst_cbarMainMenu & ".xla" Then
            ain.Installed = False
            Exit For
        End If
    Next ain
End Sub

Public Function InstallAddin(strPath As String)
'アドインインストール
'変数定義
    Dim ain     As AddIn
    Dim bFlag   As Boolean
    Dim sAddin  As String
'--------------------------------------------------------------------------------
    'アドインへのパスを取得
    sAddin = Left(strPath, Len(strPath) - 3) & "xla"
    InstallAddin = sAddin
    
    'アドインリストに乗っているかチェック
    bFlag = False
    For Each ain In Application.AddIns
        If ain.Name = cst_cbarMainMenu & ".xla" Then
            ain.Installed = True
            bFlag = True
            Exit For
        End If
    Next ain
    
    'アドインリストに乗っていれば終了
    If bFlag = True Then Exit Function
    
    'アドインリストに新しく追加する
    Application.AddIns.Add sAddin
    For Each ain In Application.AddIns
        If ain.Name = cst_cbarMainMenu & ".xla" Then
            ain.Installed = True
            Exit For
        End If
    Next ain
End Function


Public Function WhoAmI() As String
'変数定義
    Dim ThisBook As String          '現在のブック名称
'--------------------------------------------------------------------------------
    '自分自身のブック名を取得する
    ThisBook = Sheets(1).Application.ActiveWindow.Caption
    
    '戻り値の設定
    WhoAmI = ThisBook
End Function

Public Sub Auto_Remove()

End Sub

Sheel1

Option Explicit

Private Sub CommandButton1_Click()
'変数定義
    Dim vRet    As Variant
    Dim sAddin  As String
'--------------------------------------------------------------------------------
    'アドインのインストール
    sAddin = InstallAddin(Application.ThisWorkbook.Path & "\" & WhoAmI)
    
    'メニューバーの追加
    If bExistThisAddinMenu(cst_cbarMacro1) Then
        vRet = MsgBox("すでにメニューは存在します。上書きしますか?", vbYesNo)
        If vRet = vbYes Then
            Call ExcelAssist_AddinUninstall
        Else
            Exit Sub
        End If
    End If
    Call Application.CommandBars.Add(cst_cbarMainMenu, msoBarTop)
    Application.CommandBars(cst_cbarMainMenu).Visible = True
    With Application.CommandBars(cst_cbarMainMenu)
        
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro1
            .OnAction = sAddin & "!" & cst_cbarOnAction1
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro2
            .OnAction = sAddin & "!" & cst_cbarOnAction2
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro3
            .OnAction = sAddin & "!" & cst_cbarOnAction3
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro4
            .OnAction = sAddin & "!" & cst_cbarOnAction4
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro5
            .OnAction = sAddin & "!" & cst_cbarOnAction5
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro6
            .OnAction = sAddin & "!" & cst_cbarOnAction6
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro7
            .OnAction = sAddin & "!" & cst_cbarOnAction7
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro8
            .OnAction = sAddin & "!" & cst_cbarOnAction8
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro9
            .OnAction = sAddin & "!" & cst_cbarOnAction9
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacro0
            .OnAction = sAddin & "!" & cst_cbarOnAction0
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacroQ
            .OnAction = sAddin & "!" & cst_cbarOnActionQ
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacroS
            .OnAction = sAddin & "!" & cst_cbarOnActionS
        End With
        With .Controls.Add
            .Style = msoButtonCaption
            .Caption = cst_cbarMacroU
            .OnAction = sAddin & "!" & cst_cbarOnActionU
        End With
    End With
    'メニューバー表示
    Application.AddIns(cst_cbarMainMenu).Installed = True
End Sub

frmDisp

f:id:wd4096:20200530104202p:plain

Option Explicit

Private Sub cmdExit_Click()
    Unload Me
End Sub

frmSelect

f:id:wd4096:20200530103944p:plain

Private Sub cmdClose_Click()
    Unload Me
End Sub

Private Sub lstSheets_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    ActiveWorkbook.Sheets(lstSheets.Text).Activate
    Unload Me
End Sub

Private Sub lstSheets_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Select Case KeyAscii
        Case vbKeyReturn
            ActiveWorkbook.Sheets(lstSheets.Text).Activate
            Unload Me
        Case vbKeyEscape
            Unload Me
    End Select
End Sub
Private Sub UserForm_Initialize()
    Dim objSheet As Object
    
    For Each objSheet In ActiveWorkbook.Sheets
        lstSheets.AddItem (objSheet.Name)
    Next
    lstSheets.ListIndex = 0
End Sub

Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = vbKeyEscape Then
        Unload Me
    End If
End Sub

最後に

そういえば最近は全然使ってなかったりいじってなかったりします。

個人用マクロブック使ってる方も多いようですし、今更感はありますが、勤務先でも導入して流行らせてみましょうかね。

とか、考えてみたり。

「なんちゃって」BCD演算クラスを作って、nCr(組み合わせ数)計算した話

発端

本質は、「ワークシート関数「COMBIN」の結果をmodに入力すると、ありえない数値が返ってくる。」だったのです。

が、なぜかそこから、「必ず整数になるはずなので、誤差ができるのはおかしい」

という話になって、VBAで計算し始める方がちらほら。

もっと居たような気がしたのですけど、私とはけたさん以外、どなたがいたのでしたっけ。

はけたさんが書かれてるのは「パスカルの三角形」と呼ばれる二項展開の手法であるようです。。

恥ずかしながら、知らなかったのです。中高大と数学好きで通してたつもりだったのですが、サッカリンレベルで甘かったです。

でも、桁数足りないよね

で、私も作ってみたのですが、かなりぜい肉だらけのロジック。

でも、分母は毎回きちんと約分完了してたし、Excelが計算してくれる桁数には追い付けたし、まあ、いいかなあ、あとは桁数ですね。BCDライブラリ欲しいですね、というところまで進みました。

漸化式

この発言で様相が一変したと言っても過言ではないと思うのです。

実はこの計算方法、はけたさんがツイートしたものと本質的には同じ考え方なのですが、大きなメリットとして、「再起呼び出しが不要」という点があります。

VBAは再起呼び出ししやすい言語とは言えないので、この差は大きいと思うのです。

これまでのやりとりで、「BCDライブラリ必要だよね」というところまで議論は進んでいたのです。

が、8bit機でマシン語やってた方は理解できると思うのですが、掛け算とか割り算って、計算コストがそこそこ大きいのです。

CPUの演算命令に用意されてなかったら自作しないといけなかったし、CPU組み込みも昔は遅かったのです。

それをVBAでやるとなると、結構大変なのです。

まあ、やることは筆算と変わらなくて、桁上がりを検知して上の桁に1を加算したりするだけなのですが、単純な加算の方が恐ろしく単純に解決できます。

で、黒猫と香辛料さんの発言のおかげで、「加算さえ用意すれば演算できる」ことが分かってしまったわけです。

そしてBCDへ

加算だけで良いなら、作らないと損ですね、ってわけで、晩酌の肴に組んだのが以下のクラス。

Option Explicit

'クラス変数定義
Dim byteDigit_() As Byte     'BCDデータ
Dim lngMax_ As Long          '桁数

'--------------------------------------------------------------------------------
'疑似コンストラクタ
'引数:strArg As String
'・引数strArgの文字数からlngArg算出
'・クラス変数lngMaxに値セット
'・クラス変数byteDigit()を初期化
'--------------------------------------------------------------------------------
Public Sub Initialize(strArg As String)
Dim lngArg As Long
Dim lngIdx As Long

    lngArg = Len(strArg)

    '・クラス変数lngMaxに値セット
    Me.lngMax = lngArg
    
    '・クラス変数byteDigit()を初期化
    ReDim byteDigit_(lngArg - 1) As Byte
    
    'BCD変換しつつ代入
    '文字列の1桁目→配列子0の配列へ、and so on.
    For lngIdx = 0 To Me.lngMax - 1
        byteDigit_(lngIdx) = Asc(Mid(strArg, Me.lngMax - lngIdx, 1)) - Asc("0")
    Next
End Sub

'--------------------------------------------------------------------------------
'lngMax プロパティ
'--------------------------------------------------------------------------------
Public Property Get lngMax() As Long
    lngMax = lngMax_
End Property
 
Public Property Let lngMax(lngArg As Long)
    lngMax_ = lngArg
End Property
 
'--------------------------------------------------------------------------------
'byteDigit プロパティ
'--------------------------------------------------------------------------------
Public Property Get byteDigit() As Byte()
    byteDigit = byteDigit_
End Property
 
Public Property Let byteDigit(byteArg() As Byte)
    byteDigit_ = byteArg
End Property
 

'--------------------------------------------------------------------------------
'toString
'BCD表現のByte列を文字列へ変換
'--------------------------------------------------------------------------------
Public Function toString(byteArg() As Byte) As String
Dim strTemp As String
Dim lngIdx As Long

    strTemp = ""

    'BCD変換しつつ代入
    '文字列の1桁目→配列子0の配列へ、and so on.
    For lngIdx = 0 To UBound(byteArg)
        strTemp = Chr(byteArg(lngIdx) + Asc("0")) & strTemp
    Next
    toString = strTemp
End Function

'--------------------------------------------------------------------------------
'toBCD
'文字列をBCD表現のByte列へ変換
'--------------------------------------------------------------------------------
Public Function toBCD(strArg As String) As Byte()
Dim lngArg As Long
Dim lngIdx As Long
Dim lngMax As Long
Dim byteDigit() As Byte
    lngArg = Len(strArg)

    lngMax = lngArg
    
    'byteDigit()を初期化
    ReDim byteDigit(lngArg - 1) As Byte
    
    'BCD変換しつつ代入
    '文字列の1桁目→配列子0の配列へ、and so on.
    For lngIdx = 0 To lngMax - 1
        byteDigit(lngIdx) = Asc(Mid(strArg, lngMax - lngIdx - 1, 1)) - Asc("0")
    Next
End Function

'--------------------------------------------------------------------------------
'AddBCD
'メンバ変数のBCD表現のByte列に、引数に指定したBCD表現のByte列を加算する
'--------------------------------------------------------------------------------
Public Sub addBCD(byteArg() As Byte)
Dim lngIdx As Long
Dim lngMax As Long
Dim lngTemp As Long
Dim lngArgMax As Long

Dim lngArgA As Long
Dim lngArgB As Long

lngArgMax = UBound(byteArg)

    'お互いの桁数で小さい方の最大桁数-1まで計算
    For lngIdx = 0 To Max(lngArgMax, Me.lngMax - 1)
        '加算
        lngArgA = 0
        lngArgB = 0
        If lngIdx > lngArgMax Then
            '引数に指定したBCD表現のByte列を加算し終わっているので、なにもしない
        Else
            lngArgA = byteArg(lngIdx)
        End If
        
        If lngIdx > Me.lngMax - 1 Then
            'BCD表現のByte列が足りなくなったので桁を追加
            ReDim Preserve byteDigit_(Me.lngMax) As Byte
            Me.lngMax = Me.lngMax + 1
        Else
            lngArgB = byteDigit_(lngIdx)
        End If
        
        lngTemp = lngArgA + lngArgB
        
        If lngTemp > 9 Then
            '桁上がり発生
            '上位の桁が今の桁数より大きい場合、Byte列を増やす
            If (lngIdx + 1) >= Me.lngMax Then
                ReDim Preserve byteDigit_(Me.lngMax) As Byte
                Me.lngMax = Me.lngMax + 1
            End If
            
            '現在桁へ-10した値を設定
            byteDigit_(lngIdx) = lngTemp - 10
            
            '上の桁へ1を加算
            byteDigit_(lngIdx + 1) = byteDigit_(lngIdx + 1) + 1
        Else
            '桁上がり発生せず
            '現在桁へ値を設定
            byteDigit_(lngIdx) = lngTemp
        End If
    Next
End Sub

Private Function Min(lngA As Long, lngB As Long) As Long
    Min = IIf(lngA >= lngB, lngB, lngA)
End Function

Private Function Max(lngA As Long, lngB As Long) As Long
    Max = IIf(lngA >= lngB, lngA, lngB)
End Function

そして、実際に足し算を行うときに、入力を「文字列」にするためのラッパー関数を用意しました。

Function addBCD(strArgA As String, strArgB As String) As String
Dim bcdA As New bcd
Dim bcdB As New bcd

    Call bcdA.Initialize(strArgA)
    Call bcdB.Initialize(strArgB)
    
    '加算
    Call bcdA.addBCD(bcdB.byteDigit)
    
    '戻り値を返す
    addBCD = bcdA.toString(bcdA.byteDigit)
End Function

自画自賛ですが、このラッピングの仕方はすごく理想的で、「データ構造を無視できる」のが強みです。

内部処理でBCD演算のためにByte型配列を扱っていて、かつ、桁数が足りなくなると自動で桁数増やしている、なんてことを全く意識せずに足し算だけ任せられるのは便利なのです。

Function nCrBCD(lngN As Long, lngR As Long) As String
Dim strArg() As String   '演算用の文字列
Dim lngIdx As Long
Dim lngIdx2 As Long
Dim dateStart

dateStart = Now()

ReDim strArg(lngR) As String

    '演算用文字列初期化
    For lngIdx = 0 To lngR
        strArg(lngIdx) = "1"
    Next

    For lngIdx2 = 1 To lngN - lngR
        For lngIdx = 1 To lngR
            strArg(lngIdx) = addBCD(strArg(lngIdx), strArg(lngIdx - 1))
        Next
    Next

Debug.Print CDate(Now() - dateStart)

    nCrBCD = strArg(lngR)
End Function

そして最後に、黒猫と香辛料さんのコードを、BCD演算で動くようにして完了。

配列確保も動的にしたので、理論上は、「コンピューターのスペックが許す限り、何桁でも計算できるようになりました。」

で、どこまで計算できるの

確認した範囲でこんな感じでした。

1000C50:1秒くらい

10000C50:26秒くらい

100000C50:5分59秒くらい

ちなみに、100000C50は186桁で、VBAとCONMINで値はそれぞれ以下の通りです。

VBA:324791116448528873575523182071046314176283476648027244927270999288005964035859548411037117880276576299533569666297949933317955323578121238572954027153746965881539586782982104673414248000

CONBIN:324791116448529000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000

CONBIN関数が上15桁で切れてるのがわかりますね。BCD大好きってなりました。

こんな演算を見ると、「COBOL無くならないな」って感想が出てきたりします。

CやC++にはBCDライブラリありますけどデフォルトではないのでデフォルトで使えるメリットはかなり大きいのです。

次へ

BCDライブラリ、作るしかないんじゃない?と、思っています。

整数演算だけでなく小数点演算も必要なので工夫が必要ですが。

ちなみに、そういえば、BCD使った演算ルーチンの考察って、25年前にやってたな、と、思い出したので、週末当たり昔のノートを見てみようと思います。

あと、今回掲載したクラスは出来が良くないです。

速度を考えてもっとギークなつくりにできるはずなのです。

例えば、BCDでの1桁加算演算、マシン語だと単純にレジスター足し算してキャリフラグで分岐、なのですけど、VBAだと、同様に、select Case文で実現可能なのです。

速度検証してないのですけど、理論上、10進数1桁の演算は、結果が100通りしかないのですよね。10*10の演算なので。

その辺りも含めて、クラスは作り直したいと思うのです。わくわくしてきますね!

久しぶりのブログはこんな感じで締めたいと思います。

なお、まだお酒が抜けてない酔っ払いです。ぷはー。

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

ファイルのエクスポート画面

以下メニューから異なるファイル形式でエクスポート可能。

なお、オンプレミス版ではPDFのエクスポート機能が残っていますが、結構前に負荷の影響でPDF形式でのエクスポートは廃止された模様。

f:id:wd4096:20190924224351p:plain

PDFエクスポートについて

左がHackMDからのエクスポート結果。右がTyporaからのエクスポート結果。

HackMDからのエクスポートだと罫線が消えたり散々なので、Typoraにmdファイルをインポートして出力するのがよいと思います。

f:id:wd4096:20190924231514p:plain

▼参考サイト

  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」接頭辞を付与しますが、今回は説明を省略します。

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