rpxテキストを読み込んで動的にレイアウト

ActiveReportsを使ったVB6プロジェクトで、ユーザーごとに、ちょこっとだけレイアウトを変えたいときにお手軽に対応する方法

ActiveReportは、rpxというXML形式のレイアウト定義を読み書きできるので、ちょこっと変えたレイアウト(dsrとdsx)からrpxをそれぞれ作り、実行時にはこれを読み込んでレイアウトを変更するというやり方です。rpxファイルを配布したくなかったので、データベースから読み込むことにしました。rpxファイルはUTF-8、データベースから読み込んだ文字列(VB6内)はUTF-16LEなので、UTF16ToUTF8関数も作りました。

ユーザーごとのレイアウト定義を用意します。

UserReport.dsr
UserReport.dsx
UserReport.rpx

前記事の rpxファイルをDBへインポートする で UserReport.rpx をDBにインポートしておきます。アプリ実行時には、これを読み込んでLoadLayoutします。

呼び出し

    Dim obj As UserReport
    Set obj = New UserReport
    Call LoadLayout(obj, "UserReport.rpx")

共通関数

Declare Function WideCharToMultiByte Lib "kernel32" _
   (ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long, _
    ByRef lpMultiByteStr As Any, _
    ByVal cchMultiByte As Long, _
    ByVal lpDefaultChar As String, _
    ByVal lpUsedDefaultChar As Long) As Long

Public Sub LoadLayout(ByRef obj As ActiveReport, ReportID As String)
    Dim SQL         As String
    Dim OraDynaset  As OraDynaset
    Dim arr()       As String
    Dim rpx()       As Byte
    Dim i           As Long

    'バインドパラメータ設定
    With OraDataBase.Parameters
        For i = .Count - 1 To 0 Step - 1
            .Remove i
        Next
        .Add "ReportID", "", ORAPARM_INPUT, ORATYPE_VARCHAR2
        .Item("ReportID").Value = UCase(ReportID)
    End With
    
    SQL = "SELECT LINE FROM ActiveReports WHERE ReportID = :ReportID ORDER BY LINE_NO"
    Set OraDynaset = OraDataBase.CreateDynaset(SQL, ORADYN_READONLY)
    With OraDynaset
        If Not .EOF Then
            'データベースからrpxテキストをarrに読み込み
            ReDim arr(1 To .RecordCount)
            Do While Not .EOF
                arr(.RowPosition) = .Fields("LINE").Value & vbCrLf '行末に改行を付加
                .MoveNext
            Loop

            rpx = UTF16ToUTF8(Join(arr, ""))

            Call obj.LoadLayout(rpx)
        End If
    End With
End Sub

Public Function UTF16ToUTF8(UTF16 As String) As Byte()
    Const CP_UTF8 = 65001
    UTF16ToUTF8 = UnicodeToMultiByte(UTF16, CP_UTF8)
End Function

Public Function UnicodeToMultiByte(UTF16 As String, CodePage As Long) As Byte()
    Dim pInput As Long
    Dim pOutput As Long
    Dim size As Long
    Dim buf() As Byte

    'バッファサイズを取得するために、空変換してサイズだけ取得する
    pInput = StrPtr(UTF16)
    size = WideCharToMultiByte(CodePage, 0, pInput, -1, 0&, 0&, ByVal 0&, ByVal 0&)
    
    'バッファを確保してCodePageに変換する
    ReDim buf(size - 1)
    pOutput = VarPtr(buf(0))
    size = WideCharToMultiByte(CodePage, 0, pInput, -1, pOutput, size, ByVal 0&, ByVal 0&)
    
    '末尾のnullを除去する
    ReDim Preserve buf(size - 2)
    UnicodeToMultiByte = buf
End Function