★AccessVBA ～ 料金別納郵便ハガキ・宛名面 ～ テキストボックスの大きさに合わせて文字を小さくする方法（横書き、縦書き。ただし、レポートのみ。フォーム不可。）
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
※もとからレポートでしか使えないプログラムです。フォーム不可です。
フォームで使いたい場合は、AIに作り替えてもらってください。
32bitのAccessと64bitのAccessでは、作りが異なるので、それぞれ専用のmdbないし、accdb、を作ったほうがいいです。
特にAccessのハガキウィザードを使ったとき。
Win32APIを呼び出すのですが、64bitだと、それ専用に書き変えないとエラーになります。
ただ、単純に仕様通りに「PtrSaf」つけたり「LongPtr」や「LongLong」などを使ったりしてもダメでした。（更には、AIに作ってもらってもダメでした。）
64bitのAccessの場合は、もともと「Yubin7.dll」が無いこともあるのかもしれません。
わかりませんが・・・。
基本、以降にご提示した「テキストボックスの大きさに合わせて文字を小さくする」というプログラムは、そのあたりには依存しないのであまり心配はないのですが、ただ、「ハガキウィザードにて郵便番号や顧客住所などを自動で表示（あるいは印刷）するようなプログラム」では少し気をつけてください。
（ハガキウィザードが作ってくれたコードやテキストボックスを削らないといけないことがあります。）
★Accessのハガキウィザード作ったレポートのテキストボックスを、郵便番号以外を無効化する方法
（ウィザードで自動作成されたテキストボックスを消しても大丈夫にする方法）
詳細セクションのFormatイベントのコードを、
「Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)」
からすぐ下の変数宣言の部分は一応残しておいて、
そのすぐ下以降の部分は全部消すか、コメントアウトします。
レポートデザイン画面のテキストボックスは、氏名と住所と差出人のそれらは消すか、小さくして非表示氏にしてOKです。
郵便番号付近や宛名や住所の付近の小さなテキストボックスらしきものは、消すとエラーになるものは残しておき、非表示設定にします。
一度に全部消すと、エラーになるかもなので、１つ１つ、「消す」「レポート表示」を繰り返して、逐一確認しながら消してください。
プログラム側を消してしまったので、「逆に残すとエラーになる」なんてこともあるかもしれません。
その場合は消してしまってください。
★横書きテキストボックスの場合の、プログラムの呼び出し方法
Accessのハガキウィザードで作ったDMなどは、例えば前項のように「たくさん消してしまったコード」の部分に、以下のように書き足して縮小表示をします。
Call FontMinimize01(Me, Me("tbx_氏名"), 30)
ウィザードでのハガキ以外のレポートなら、好きな場所に書いて縮小表示を実行します。
なお、Meの部分は、レポートのオブジェクトそのものを指定します。
（ただ、基本、Meのままでいいです。もとからレポートでしか使えないプログラムなので。フォーム不可です。もしフォームでも必要なら、AIに作り替えてもらってください。）
「"tbx_氏名"」の部分は、縮小表示したいテキストボックスなどのコントロール名を書きます。
30、18、15、などのラスト部分の数字は、
「縮小表示したいテキストボックスなどにおける、その最大フォントサイズの上限設定値」です。
|
1 2 3 4 5 6 7 8 |
' ' Call FontMinimize01(Me, Me("tbx_氏名"), 30) Call FontMinimize01(Me, Me("tbx_住所01"), 18) Call FontMinimize01(Me, Me("tbx_住所02"), 15) ' ' |
★縦書きテキストボックスの場合の、プログラムの呼び出し方法
Accessのハガキウィザードで作ったDMなどは、例えば前項のように「全部消してしまった」部分に、以下のように書き足して縮小表示をします。
Call FontMinimize01_tate01(Me, Me("tbx_氏名"), 30)
ウィザードでのハガキ以外のレポートなら、好きな場所に書いて縮小表示を実行します。
こちらも、Meの部分は、レポートやフォームのオブジェクトそのものを指定します。
（ただ、基本、Meのままでいいです。もとからレポートかフォームでしか使えないプログラムなので）
「"tbx_氏名"」の部分は、縮小表示したいテキストボックスなどのコントロール名を書きます。
30、18、15、などのラスト部分の数字は、
「縮小表示したいテキストボックスなどの最大フォントサイズの上限設定値」です。
|
1 2 3 4 5 6 7 8 |
' ' Call FontMinimize01_tate01(Me, Me("tbx_氏名"), 30) Call FontMinimize01_tate01(Me, Me("tbx_住所01"), 18) Call FontMinimize01_tate01(Me, Me("tbx_住所02"), 15) ' ' |
★横書きテキストボックス用のプログラム（標準モジュールにコピペ）
※本当は「i_BaseSize」という変数をも引数にして「MAXFONTSIZE」（フォントの大きさの最大上限値）とは区別したほうがいいのですが、今回は一緒にしてしまっています。
「i_BaseSize」は、各テキストボックスの既定のフォントの大きさです。
横書き用では今回は使っていません。
今回は、「MAXFONTSIZE」を越えることはもとからないので、横書き用では「MAXFONTSIZE」１本で行ってしまいました。
ただ、この先、もし、「MAXFONTSIZE」と「i_BaseSize」の値を異なる値にしないといけないようなことが出てこれば、そのときはそのように書き変えが必要です。
「i_BaseSize」を4つ目の引数にする、ということです。
※このプログラムは、少しトリッキーなことをしています。
詳しくやヒントはこちら（AIに聞いたこと）→「access_report_tbx-font-size-mini-hint01.pdf」
・以下、AIが、フォントサイズの初期化をして小さくなりすぎない様に修正してくれたもの
（サンプルのmdbやaccdbには入っていません。）
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
' ' Sub FontMinimize01(o_Report01 As Report, o_tbx01 As TextBox, MAXFONTSIZE As Integer) Dim L1 As String Dim S1 As Single Dim S2 As Single Dim S3 As Single Dim i_BaseSize As Integer '★追加 ' 基準のフォントサイズ（初期値）をセット i_BaseSize = MAXFONTSIZE '★追加 S3 = 0.9 ' ★ここを o_tbx01.FontSize ではなく i_BaseSize に変更 o_Report01.FontSize = i_BaseSize L1 = o_tbx01.Value '横書き用 S1 = o_Report01.TextWidth(L1) S2 = o_tbx01.Width / S1 ' ★ここも o_tbx01.FontSize ではなく i_BaseSize から計算 o_tbx01.FontSize = Int(i_BaseSize * S2 * S3) If o_tbx01.FontSize > MAXFONTSIZE Then o_tbx01.FontSize = MAXFONTSIZE End If End Sub ' ' |
・以下、AI修正前のもの（サンプルのmdbやaccdbには入っています。）
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
' ' Sub FontMinimize01(o_Report01 As Report, o_tbx01 As TextBox, MAXFONTSIZE As Integer) Dim L1 As String Dim S1 As Single Dim S2 As Single Dim S3 As Single ' Dim MAXFONTSIZE As Integer '★追加 ' MAXFONTSIZE = 28 '★追加 S3 = 0.9 o_Report01.FontSize = o_tbx01.FontSize L1 = o_tbx01.Value '横書き用？ S1 = o_Report01.TextWidth(L1) S2 = o_tbx01.Width / S1 o_tbx01.FontSize = Int(o_tbx01.FontSize * S2 * S3) If o_tbx01.FontSize > MAXFONTSIZE Then '★追加 o_tbx01.FontSize = MAXFONTSIZE '★追加 End If '★追加 End Sub ' ' |
★縦書きテキストボックス用のプログラム（標準モジュールにコピペ）
※以前のプログラムは32bitだと「住所2（ビル名など）」の列がNull（空白）でもエラーが出なかったのですが、64bitのときはエラーが出るので一応両方でエラーが出ないようにはしてみました。
ぜんぜん完全じゃないのでエラーが出たらご自分で直してください。
※本当は「i_BaseSize」も引数にして「MAXFONTSIZE」（フォントの大きさの最大上限値）とは区別したほうがいいのですが、今回は一緒にしてしまっています。
「i_BaseSize」は、各テキストボックスの既定のフォントの大きさです。
今回は、「MAXFONTSIZE」を越えることはもとからないので、同じ値にしてしまいました。
ただ、この先、もし、「MAXFONTSIZE」と「i_BaseSize」の値を異なる値にしないといけないようなことが出てこれば、そのときはそのように書き変えが必要です。
「i_BaseSize」を4つ目の引数にする、ということです。
※このプログラムは、少しトリッキーなことをしています。
詳しくやヒントはこちら（AIに聞いたこと）→「access_report_tbx-font-size-mini-hint01.pdf」
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
' ' ''以下、32bitのAccessならエラーが出ない？コード 'Sub FontMinimize01_tate01(o_Report01 As Report, o_tbx01 As TextBox, MAXFONTSIZE As Integer) ' ' ' Dim L1 As String ' Dim S1 As Single ' Dim S2 As Single ' Dim S3 As Single '' Dim MAXFONTSIZE As Integer ' Dim NewFontSize As Integer ' Dim CharCount As Long ' Dim i_BaseSize As Integer ' '' MAXFONTSIZE = 28 ' i_BaseSize = MAXFONTSIZE ' S3 = 0.85 ' ' ' ★毎回、基準のフォントサイズ（初期値）をレポート側にセットしてリセットします ' o_Report01.FontSize = i_BaseSize ' ' ' Null（空文字）対策 ' L1 = Nz(o_tbx01.Value, "") ' If L1 = "" Then ' o_tbx01.FontSize = i_BaseSize ' 空のときは元のサイズに戻す ' Exit Sub ' End If ' ' ' 文字数をカウント（改行コードを取り除く） ' Dim cleanStr As String ' cleanStr = Replace(Replace(L1, vbCr, ""), vbLf, "") ' CharCount = Len(cleanStr) ' If CharCount = 0 Then ' o_tbx01.FontSize = i_BaseSize ' Exit Sub ' End If ' ' ' 「"あ" という文字1文字の高さ」に「文字数」を掛け算 ' ' ※基準サイズ（i_BaseSize）の状態での「あ」の高さを正しく取得します ' S1 = o_Report01.TextHeight("あ") * CharCount ' ' ' テキストボックスの「高さ(Height)」と「文字全体の高さ(S1)」を比較 ' S2 = o_tbx01.Height / S1 ' ' ' 文字が少ないときに巨大化するのを防ぐため、倍率は最大1（等倍）にする ' If S2 > 1 Then S2 = 1 ' ' ' ★【修正】書き換わってしまったフォントサイズではなく、常に「i_BaseSize」を基準に計算します ' NewFontSize = Int(i_BaseSize * S2 * S3) ' ' ' 最大フォントサイズ（28）を超えないように制限 ' If NewFontSize > MAXFONTSIZE Then ' NewFontSize = MAXFONTSIZE ' End If ' ' ' 小さくなりすぎないよう最低値（5pt）を担保 ' If NewFontSize < 5 Then ' NewFontSize = 5 ' End If ' ' ' 計算された安全なサイズをテキストボックスに適用 ' o_tbx01.FontSize = NewFontSize ' ' 'End Sub Sub FontMinimize01_tate01(o_Report01 As Report, o_tbx01 As TextBox, MAXFONTSIZE As Integer) Dim L1 As String Dim S1 As Single Dim S2 As Single Dim S3 As Single ' Dim MAXFONTSIZE As Integer Dim NewFontSize As Integer Dim CharCount As Long Dim i_BaseSize As Integer ' MAXFONTSIZE = 28 i_BaseSize = MAXFONTSIZE ' S3 = 0.85 'テキストボックスぎちぎちにならないよう、余裕を持たせるために係数をかける形にした。 S3 = 1 '実際にやってみると、 'テキストボックスのほうが長くて余りが出ることが多いので、 'つまり、0.85だと余裕がありすぎて、 '逆に「かえって文字が小さくなってしまう」ので、 '「あえてぎちぎちを」目指す。 'なので、１でいいし、もしかしたら、 '1.03とか、1.1でもいいかも？ 'レポートをプレビュー表示して、必要に応じて値は変える。 ' ★毎回、基準のフォントサイズ（初期値）をレポート側にセットしてリセットします o_Report01.FontSize = i_BaseSize ' Null（空文字）対策 L1 = Nz(o_tbx01.Value, "") If L1 = "" Then o_tbx01.FontSize = i_BaseSize ' 空のときは元のサイズに戻す Exit Sub End If ' 文字数をカウント（改行コードを取り除く） Dim cleanStr As String cleanStr = Replace(Replace(L1, vbCr, ""), vbLf, "") CharCount = Len(cleanStr) If CharCount = 0 Then o_tbx01.FontSize = i_BaseSize Exit Sub End If ' 「"あ" という文字1文字の高さ」に「文字数」を掛け算 ' ※基準サイズ（i_BaseSize）の状態での「あ」の高さを正しく取得します S1 = o_Report01.TextHeight("あ") * CharCount ' テキストボックスの「高さ(Height)」と「文字全体の高さ(S1)」を比較 S2 = o_tbx01.Height / S1 ' 文字が少ないときに巨大化するのを防ぐため、倍率は最大1（等倍）にする If S2 > 1 Then S2 = 1 ' ★【修正】書き換わってしまったフォントサイズではなく、常に「i_BaseSize」を基準に計算します NewFontSize = Int(i_BaseSize * S2 * S3) ' 最大フォントサイズを超えないように制限 If NewFontSize > MAXFONTSIZE Then NewFontSize = MAXFONTSIZE End If ' 小さくなりすぎないよう最低値（６pt）を担保 If NewFontSize < 6 Then NewFontSize = 6 End If ' 計算された安全なサイズをテキストボックスに適用 o_tbx01.FontSize = NewFontSize End Sub ' ' |
★DMハガキ用。数字を漢数字に変換する。
Accessのハガキ印刷の宛名印刷の場合、テキストボックスのコントロールソースで使います。
例
=SafeToKanjiNum(StFixDashCharForVert([住所1]))
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
' ' Public Function SafeToKanjiNum(ByVal TargetStr As String) As String ' ------------------------------------------------------------------------- ' 機能：文字列内の半角・全角数字を、安全に漢数字（一二三...）に変換する ' 引数：TargetStr = 変換対象の文字列（Nullや空文字でもエラーになりません） ' ------------------------------------------------------------------------- On Error GoTo ErrorHandler ' 引数が空（文字数ゼロ）またはNullの場合は、そのまま空文字を返して安全に終了 If Len(TargetStr & "") = 0 Then SafeToKanjiNum = "" Exit Function End If Dim i As Long Dim checkChar As String Dim resultStr As String ' 文字列を1文字ずつチェックして変換 For i = 1 To Len(TargetStr) checkChar = Mid(TargetStr, i, 1) Select Case checkChar ' 半角数字、または全角数字の場合に漢数字へ置換 Case "0", "０": resultStr = resultStr & "〇" Case "1", "１": resultStr = resultStr & "一" Case "2", "２": resultStr = resultStr & "二" Case "3", "３": resultStr = resultStr & "三" Case "4", "４": resultStr = resultStr & "四" Case "5", "５": resultStr = resultStr & "五" Case "6", "６": resultStr = resultStr & "六" Case "7", "７": resultStr = resultStr & "七" Case "8", "８": resultStr = resultStr & "八" Case "9", "９": resultStr = resultStr & "九" ' 数字以外（漢字、ひらがな、アルファベット、ハイフン等）はそのまま結合 Case Else resultStr = resultStr & checkChar End Select Next i SafeToKanjiNum = resultStr Exit Function ErrorHandler: ' 万が一予期せぬエラーが起きた場合は、システムを止めずに元の文字列をそのまま返す SafeToKanjiNum = TargetStr End Function ' ' |
★DMハガキ用。ハイフンを縦書きハイフンに変換する。
こちらも、Accessのハガキ印刷の宛名印刷の場合、テキストボックスのコントロールソースで使います。
※以前のプログラムは32bitだと「住所2（ビル名など）」の列がNull（空白）でもエラーが出なかったのですが、64bitのときはエラーが出るので一応両方でエラーが出ないようにはしてみました。
ぜんぜん完全じゃないのでエラーが出たらご自分で直してください。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
' ' ''旧の32bitAccessだとエラーが出ない？コード。 'Private Function StFixDashCharForVert(st As String) As String ' Dim i As Integer ' i = InStr(1, st, Chr(-32388), vbBinaryCompare) ' Do While (i > 0) ' Mid(st, i, 1) = Chr(-32421) ' i = InStr(i, st, Chr(-32388), vbBinaryCompare) ' Loop ' StFixDashCharForVert = st 'End Function Public Function StFixDashCharForVert(st As Variant) As Variant Dim i As Variant i = InStr(1, st, Chr(-32388), vbBinaryCompare) If IsNull(i) = True Then i = 0 Else End If Do While (i > 0) Mid(st, i, 1) = Chr(-32421) i = InStr(i, st, Chr(-32388), vbBinaryCompare) Loop 'この関数はテキストボックスのコントロールソースで使うからか、 '「st」がオブジェクトの時と、テキストデータのときがある。 '「st」がオブジェクトの時、エラーが出ないとも限らないので '念のため、条件分岐しておく。 ' ↓ If IsObject(st) = True Then If IsNull(st.Value) Then StFixDashCharForVert = "" Else StFixDashCharForVert = st.Value End If Else If IsNull(st) Then StFixDashCharForVert = "" Else StFixDashCharForVert = st End If End If End Function ' ' |
