SIBAINUのメモ帳

フォームのテキストボックスに数字のみ入力

配置：　フォームに、テキストボックスx (xは0から5まで)を配置
動作：　テキストボックス1からテキストボックス5に入力するごとに、テキストボックス0
　　　に合計するようにします。
設定：　テキストボックスの「IME入力モード」を使用不可に設定

COPY

Option Compare Database
Option Explicit
'-------------------------------------------------------------------
 
Private WithEvents myControl As C_Controls
 
'-------------------------------------------------------------------
Private Sub Form_Load()
 
    Set myControl = New C_Controls
    With myControl
        Set .Parent = Me
        Call .Init
    End With
 
End Sub
'-------------------------------------------------------------------
Private Sub mycontrol_Change(myCont As Object)
    Dim Total               As Variant
    Dim I                   As Long
 
    Select Case myCont.Name
    Case "テキスト1", "テキスト2", "テキスト3", "テキスト4", "テキスト5"
        Total = ValOut(myCont.Text)
        For I = 2 To 10 Step 2
            If myCont.Name <> "テキスト" & I Then
                Total = Total + ValOut(Me("テキスト" & I).Value)
            End If
        Next I
        Me.テキスト0.Value = Total
    End Select
 
End Sub
'-------------------------------------------------------------------
Private Function ValOut(Val As Variant) As Variant
 
    If Nz(Val, "") = "" Then
        ValOut = 0
    Else
        ValOut = CDec(Val)
    End If
    
End Function
'-------------------------------------------------------------------
Private Sub mycontrol_KeyPress(myCont As Object, KeyAscii As Integer)
 
    Select Case myCont.Name
    Case "テキスト1", "テキスト2", "テキスト3", "テキスト4", "テキスト5"
        If (KeyAscii < Asc("0") And KeyAscii > 31) Or KeyAscii > Asc("9") Then
            If KeyAscii = Asc(".") Then
                If InStr(myCont.Text, ".") > 0 Then
                    KeyAscii = 0
                End If
            Else
                KeyAscii = 0
            End If
        End If
    End Select
 
End Sub

レポートを縮小拡大するプロシージャ

R: 拡大/縮小の比率
    1.15    'B5サイズをA4サイズに拡大
    0.817   'B4サイズをA4サイズに縮小

COPY

Public Sub ReportSizeChange(ReportName As String, R As Double)
    Dim NewReportName As String, ctl As Control, rpt As Report, i As Integer
     
    If R = 1 Then
        Exit Sub
    ElseIf R < 1 Then
        NewReportName = ReportName & "_SizeDown"
    Else
        NewReportName = ReportName & "_SizeUp"
    End If
    DoCmd.CopyObject , NewReportName, acReport, ReportName
     
    On Error Resume Next
    DoCmd.OpenReport NewReportName, acViewDesign
    Set rpt = Reports(NewReportName)
    If R > 1 Then
        rpt.Width = rpt.Width * R
        For i = 0 To 8
            rpt.Section(i).Height = rpt.Section(i).Height * R
        Next
    End If
     
    For Each ctl In rpt.Controls
        With ctl
            .Move .Left * R, .Top * R, .Width * R, .Height * R
            .FontSize = Int(.FontSize * R)
        End With
    Next
     
    If R < 1 Then
        rpt.Width = rpt.Width * R
        For i = 0 To 8
            rpt.Section(i).Height = rpt.Section(i).Height * R
        Next
    End If
     
    Set rpt = Nothing
End Sub

フォーム内でレコードを保存しようとするたびに変更内容の確認を求める方法

COPY

Private Sub Form_BeforeUpdate(Cancel As Integer) 
    Dim strMsg As String 
    Dim iResponse As Integer 
 
    '確認メッセージ
    strMsg = "変更があります。更新しますか?" & Chr(10) 
    strMsg = strMsg & "「はい」「いいえ」をクリックしてください。" 
 
    'メッセージの表示
    iResponse = MsgBox(strMsg, vbQuestion + vbYesNo, "更新確認?") 
    
    '「いいえ」がクリックされた場合 
    If iResponse = vbNo Then 
        '変更を戻す 
        DoCmd.RunCommand acCmdUndo 
        '手続きのキャンセル
        Cancel = True 
    End If 
 
End Sub
'-------------------------------------------------------------------
Private Sub cmd更新_Click()
    Dim strMsg As String 
    Dim iResponse As Integer 
 
    If Not Me.Dirty Then
        Msgbox "変更はありません。キャンセルします。"
        Exit Sub
    End If
 
    '確認メッセージ
    strMsg = "更新しますか?" & Chr(10) 
    strMsg = strMsg & "「はい」「いいえ」をクリックしてください。" 
 
    iResponse  = MsgBox(strMsg, vbQuestion + vbYesNo, "更新確認?")
 
    If iResponse = vbYes Then
        Me.BeforeUpdate = ""
        DoCmd.RunCommand acCmdSaveRecord
        Me.BeforeUpdate = "[イベント プロシージャ]"
        Msgbox "更新されました。"
    Else
        DoCmd.RunCommand acCmdUndo
        Msgbox "更新はキャンセルされました。"
    End If
 
    DoEvents
 
End Sub

グループの縦をグループ名、横を月にした集計を作成

COPY

Private Sub Unko()
    Dim subSQL          As String
    Dim mySQL           As String
    Dim NenTuki()       As String
    Dim I               As Long
 
    '作成する年月の配列を作成
    ReDim NenTuki(12)
    For I = 1 To 12
        NenTuki(I) = StrConv(Format(DateSerial(2021, 3 + I, 1), "geemm"), vbUpperCase)
    Next I
 
    '基本となるクエリの作成
    subSQL = "SELECT"
    subSQL = subSQL & " A.登録番号"
    For I = 1 To UBound(NenTuki)
        subSQL = subSQL & ", MAX(IIf(A.年月='" & NenTuki(I) & "',A.給油,Null)) AS " & "O_" & NenTuki(I)
        subSQL = subSQL & ", MAX(IIf(A.年月='" & NenTuki(I) & "',A.稼働日数,Null)) AS " & "K_" & NenTuki(I)
        subSQL = subSQL & ", MAX(IIf(A.年月='" & NenTuki(I) & "',A.走行距離,Null)) AS " & "S_" & NenTuki(I)
    Next I
    subSQL = subSQL & " FROM"
    subSQL = subSQL & " (SELECT"
    subSQL = subSQL & " StrConv(Format(X.[シリアル値],'gee') & Format(X.[シリアル値],'mm'),8) AS 年月"
    subSQL = subSQL & ", X.登録番号"
    subSQL = subSQL & ", X.給油"
    subSQL = subSQL & ", X.稼働日数"
    subSQL = subSQL & ", X.走行距離"
    subSQL = subSQL & " FROM 運行 AS X)"
    subSQL = subSQL & " AS A"
    subSQL = subSQL & " GROUP BY A.登録番号"
    subSQL = subSQL & " ORDER BY A.登録番号"
 
    '出力フィールドの作成
    mySQL = "SELECT"
    mySQL = mySQL & " B.登録番号"
    '月の給油フィールド
    For I = 1 To UBound(NenTuki)
        mySQL = mySQL & ", B.O_" & NenTuki(I)
    Next I
    '給油合計フィールド
    mySQL = mySQL & ", (0 "     '0はダミー
    For I = 1 To UBound(NenTuki)
        mySQL = mySQL & " + Nz(B.O_" & NenTuki(I) & ",0)"
    Next I
    mySQL = mySQL & ") AS 給油合計"
    '月の稼働日数フィールド
    For I = 1 To UBound(NenTuki)
        mySQL = mySQL & ", B.K_" & NenTuki(I)
    Next I
    '稼働日数合計フィールド
    mySQL = mySQL & ", (0 "     '0はダミー
    For I = 1 To UBound(NenTuki)
        mySQL = mySQL & " + Nz(B.K_" & NenTuki(I) & ",0)"
    Next I
    mySQL = mySQL & ") AS 稼働日数合計"
    '月の走行距離フィールド
    For I = 1 To UBound(NenTuki)
        mySQL = mySQL & ", B.S_" & NenTuki(I)
    Next I
    '年間走行距離フィールド
    mySQL = mySQL & ", ("
    '    計算期間の有効データを保持する最終月を求めデータを取得する
    For I = 12 To 1 Step -1
        If I = 12 Then
            mySQL = mySQL & " Switch(Not IsNull(B.S_" & NenTuki(I) & "),B.S_" & NenTuki(I)
        Else
            mySQL = mySQL & ", Not IsNull(B.S_" & NenTuki(I) & "), B.S_" & NenTuki(I)
        End If
    Next I
    mySQL = mySQL & ", True, Nz(B.S_" & NenTuki(1) & "))"      'Switchの最終処理
    mySQL = mySQL & " - "
    '    -計算期間の有効データを保持する最初月を求めデータを取得する
    For I = 1 To 12
        If I = 1 Then
            mySQL = mySQL & " Switch(Not IsNull(B.S_" & NenTuki(I) & "),B.S_" & NenTuki(I)
        Else
            mySQL = mySQL & ", Not IsNull(B.S_" & NenTuki(I) & "), B.S_" & NenTuki(I)
        End If
    Next I
    mySQL = mySQL & ", True, Nz(B.S_" & NenTuki(12) & "))"      'Switchの最終処理
    mySQL = mySQL & ") AS 年間走行距離"
    mySQL = mySQL & " FROM (" & subSQL & ") AS B;"
 
    '作成したSQL分を表示
    Me.temp = mySQL
 
    'エクセルに出力
    Call エクセル(mySQL)
 
End Sub

レコードセットをエクセルに書き込む

COPY

Private Sub エクセル(ByVal mySQL As String)
    Dim Rst                 As Recordset
    Dim xls                 As Object
    Dim I                   As Long
 
    'レコードセットを作成
    Set Rst = CurrentDb.OpenRecordset(mySQL)
 
    'Excelオブジェクトを生成
    Set xls = CreateObject("Excel.Application")
    xls.Visible = True
 
    '新しいブックを追加
    With xls.Application.Workbooks.Add
        '1行目の1列目からフィールド名を出力
        For I = 0 To Rst.Fields.Count - 1
            .Sheets(1).Cells(1, I + 1).Value = Rst.Fields(I).Name
        Next I
        '2行目の1列目からレコードセットを出力
        .Sheets(1).Cells(2, 1).CopyFromRecordset Rst
    End With
 
    'オブジェクトの参照の破棄
    Set xls = Nothing
    Rst.Close
    Set Rst = Nothing
 
End Sub