Access

　 サ　ン　プ　ル

'エクセル出力

Sub sample1
Dim dbs As Database
Dim rst As Recordset
Dim strSQL As String

Dim xl As Object
Dim st As Object

Dim i As Long

    Set dbs = CurrentDb
    strSQL = "SELECT * FROM ＸＸＸＸＸT WHERE TBLID = '0100'"
    Set rst = dbs.OpenRecordset(strSQL)

    '新規ブック
    'Set xl = CreateObject("Excel.Application") 'オブジェクトの作成
    'xl.Visible = True 'Excelを見えるようにする
    'xl.Workbooks.Add   'Excelのブックを作成

    '既存ブック
    Set st = GetObject(Application.CurrentProject.Path & "\test.xls")
    Set xl = st.Application
    xl.Visible = True
    xl.Windows("test.xls").Visible = True
    xl.Worksheets("Sheet1").Activate
    xl.Cells.Select
    xl.Selection.ClearContents

    i = 2
    While rst.EOF = False
        With rst
            xl.Worksheets(1).Cells(i, 1) = .Fields("TKEY") '!TKEY
            xl.Worksheets(1).Cells(i, 2) = .Fields("KAREA") '!KAREA
            i = i + 1
            .MoveNext
        End With
    Wend

    rst.Close
    dbs.Close

    Set rst = Nothing
    Set dbs = Nothing

    xl.Worksheets(1).Columns("A:B").Select
    xl.Worksheets(1).Columns("A:B").EntireColumn.AutoFit
    xl.Worksheets(1).Cells(1, 1).Select

    Set xl = Nothing
    Set st = Nothing
End Sub

Private Sub Excel_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qd As DAO.QueryDef
Dim i As Long
Dim j As Long
Dim xl As Object
    '新規ブック
    Set xl = CreateObject("Excel.Application") 'オブジェクトの作成
    xl.Visible = True                           'Excelを見えるようにする
    xl.Workbooks.Add                           'Excelのブックを作成

    Set db = CurrentDb
    Dim MyTBL As TableDef
    Dim strFld As String

    j = 1
    Set MyTBL = db.TableDefs("T_xxx)
    For i = 1 To MyTBL.Fields.Count
        strFld = MyTBL.Fields(i - 1).Name
        xl.Worksheets(1).Cells(1, j) = strFld
        j = j + 1
    Next
    Set MyTBL = Nothing

    Set qd = db.CreateQueryDef("")
    'データ抽出
    qd.SQL = "SELECT * FROM T_xxx WHERE 年度='2006 ' AND No in('10169','10206') ORDER BY 1,2,3 "
    Set rs = qd.OpenRecordset()
    i = 2
    While rs.EOF = False
        With rs
            xl.Worksheets(1).Cells(i, 1) = .Fields("No")
            i = i + 1
            .MoveNext
        End With
    Wend
    rs.Close
    qd.Close
    db.Close
    Set rs = Nothing
    Set qd = Nothing
    Set db = Nothing

    xl.Worksheets(1).Columns("A:AJ").Select
    xl.Worksheets(1).Columns("A:AJ").EntireColumn.AutoFit
    xl.Worksheets(1).Cells(1, 1).Select
    Set xl = Nothing
End Sub

'SetOption メソッドで MaxLocksPerFile の値を一時的に変更する

'SetOption メソッドで MaxLocksPerFile の値を一時的に変更する
'「ディスクの空き領域またはメモリが不足しています」エラー回避
'Microsoft DAO 3.6 Object Library を参照
Option Compare Database
Option Explicit
'http://support.microsoft.com/kb/209940/
Sub LargeUpdate()
   On Error GoTo LargeUpdate_Error
   Dim db As DAO.Database, ws As DAO.Workspace
   ' Set MaxLocksPerFile.
   DBEngine.SetOption dbMaxLocksPerFile, 200000
'   Set db = CurrentDb
'   Set ws = Workspaces(0)
'   ws.BeginTrans
'   db.Execute "UPDATE T_XXX SET aaa = 'xxx'", dbFailOnError
'   ws.CommitTrans
'   db.Close
   MsgBox "Done!"
   Exit Sub
LargeUpdate_Error:
   MsgBox Err & " " & Error
   ws.Rollback
   MsgBox "Operation Failed - Update Canceled"
End Sub

'テキストのimport

Function dataImport(strText As String) As Boolean
Dim objSYS As Object
Dim objTxtIn As Object
Dim objTxtOt As Object
Dim strData As String
Dim strouttext As String
On Error GoTo Err_Label
    dataImport = True
    strouttext = Left(strText, Len(strText) - 4) & "out.txt"
    Set objSYS = CreateObject("Scripting.FileSystemObject")
    Set objTxtIn = objSYS.OpenTextFile(strText)
    Set objTxtOt = objSYS.CreateTextFile(strouttext)
    Do Until objTxtIn.atendofline = True
        strData = objTxtIn.ReadLine
        If Mid(strData, 4, 1) = "E" Then
            strData = varArrayKey(i) & Left(strData, 3) & Mid(strData, 5,
143) & vbCrLf
            objTxtOt.Write (strData)
        End If
    Loop
    objTxtOt.Close
    objTxtIn.Close
    Set objTxtOt = Nothing
    Set objTxtIn = Nothing
    Set objSYS = Nothing

    DoCmd.TransferText acImportFixed, "pattern1", "TBLXXX", strouttext
    Kill strouttext

    Exit Function
Err_Label:
    dataImport = False
    MsgBox Err.Description, vbCritical, pubTitle
End Function

'配列

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim tbl As DAO.TableDef
Dim fld As DAO.FIELD

Dim i As Long
Dim j As Long
Dim k As Long
Dim strItem() As String
Dim strType() As String
Dim strSize() As String
Dim lonitem As Long

Private Sub tblset(strtbl As String)

    Set db = CurrentDb()
    Set tbl = db.TableDefs(strtbl)
    lonitem = tbl.Fields.Count - 7
ReDim strItem(lonitem) As String
ReDim strType(lonitem) As String
ReDim strSize(lonitem) As String

    k = 1
    For Each fld In tbl.Fields
        DoEvents
        For j = 0 To fld.Properties.Count - 1
            Select Case fld.Properties(j).Name
                Case "Name"
                    strItem(k) = fld.Properties(j)
                Case "Type"
                    Select Case fld.Properties(j)
                        Case 1
                            strType(k) = "Boolean"
                        Case 2
                            strType(k) = "Byte"
                        Case 3
                            strType(k) = "Integer"
                        Case 4
                            strType(k) = "Long"
                        Case 5
                            strType(k) = "Currency"
                        Case 6
                            strType(k) = "Single"
                        Case 7
                            strType(k) = "Double"
                        Case 8
                            strType(k) = "Date"
                        Case 10
                            strType(k) = "Text"
                        Case 11
                            strType(k) = "LongBinary"
                        Case 12
                            strType(k) = "Memo"
                        Case 15
                            strType(k) = "GUID"
                        Case Else
                    End Select
                Case "Size"
                    strSize(k) = fld.Properties(j)
                Case Else
            End Select
        Next j
        k = k + 1
        If k > lonitem Then
            Exit For
        End If
    Next fld

    Set tbl = Nothing
    db.Close
    Set db = Nothing
End Sub

'タイトル

Private Sub test()
    '参照設定 DAO 3.6
    Dim db As Database
    Set db = CurrentDb
    MsgBox db.Properties("AppTitle")
    Set db = Nothing
End Sub

Function ChangeTitle()
    Dim db As Database, prp As Property
    Const conPropNotFoundError = 3270
    On Error GoTo ErrorHandler
    ' Return Database variable pointing to current database.
    Set db = CurrentDb
    ' Change title bar.
    db.Properties!AppTitle = "User = " & CurrentUser & " Computer = " & Environ("COMPUTERNAME")
    ' Update title bar on screen.
    Application.RefreshTitleBar
    Set db = Nothing
    Exit Function
ErrorHandler:
    If Err.Number = conPropNotFoundError Then
        Set prp = db.CreateProperty("AppTitle", dbText, "User = " & CurrentUser)
        db.Properties.Append prp
    Else
        MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
    End If
    Set db = Nothing
    Resume Next
End Function

'アクティブなオブジェクトの名前を取得

strName = Application.CurrentObjectName

'Tableのエクスポート

DoCmd.TransferDatabase acExport, "Microsoft Access", "C:\data_test.mdb", acTable, "SYS00", "SYS00", False, False

'Export

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, strTbl, strFile, True

'オートナンバー型フィールドを作成し、その "新規レコードの値" プロパティを "ランダム" に設定する方法

Sub CreateRandomAutonumber()
' Create database, tabledef, and field objects.
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim f As DAO.Field

' Set the database object to the current database.
' Set the tabledef object to a new table named Table1.
' Set the f (field) object to a new field in Table1 named MyAutoNumber.

Set db = CurrentDb
Set td = db.CreateTableDef("Table1")
Set f = td.CreateField("MyAutoNumber")

' Set the type and auto-increment properties for the Table1 field named
' MyAutoNumber.

f.Type = dbLong
f.Attributes = dbAutoIncrField

' Append the MyAutoNumber field to Table1.
td.Fields.Append f

' Create a new text field in Table1.
Set f = td.CreateField("MyTextField")

' Set the type property for MyTextField.
f.Type = dbText

' Append the MyTextField field to Table1.
td.Fields.Append f

' Append the Table1 tabledef to the database.
db.TableDefs.Append td

' Set the default value for MyAutoNumber to a random number function.
td.Fields("MyAutoNumber").DefaultValue = "GenUniqueID()"

' Refresh the database window.
Application.RefreshDatabaseWindow

End Sub

'ループ

If Not Me.sub.Form.Recordset.BOF Then
    Me.sub.Form.Recordset.MoveFirst
    Do Until Me.sub.Form.Recordset.EOF
        MsgBox Me.sub.Form.txtxxx
        Me.sub.Form.Recordset.MoveNext
    Loop
End If

Dim lonRec As Long
Dim i As Long
    Me.sub.SetFocus
    DoCmd.GoToRecord , , acLast
    lonRec = Me.sub.Form.CurrentRecord
    DoCmd.GoToRecord , , acFirst
    For i = 1 To lonRec
        If Me.sub.Form.chkxxx = True Then
            MsgBox Me.sub.Form.txtxxx
        End If
        If i = lonRec Then Exit For
        DoCmd.GoToRecord , , acNext
    Next i

'配列

Sub tblrtn()
Dim varArrayKey As Variant
Dim i As Long
    varArrayKey = Array(, "AREA1", "AREA2", "AREA3")
    For i = 1 To UBound(varArrayKey)
        'Me.Controls("xxx" & i).Caption
        MsgBox varArrayKey(i)
    Next i
End Sub

'値の確認

'Access画面の入力なし項目
If Me.txta = "" Then
Debug.Print "a-1 ブランク" '×
End If
If IsNull(Me.txtb) = True Then
Debug.Print "b-1 null" '○
End If
If IsEmpty(Me.txtc) = True Then
Debug.Print "c-1 empty" '×
End If

Dim a As Variant
Dim b As Variant
Dim c As Variant
If a = "" Then
Debug.Print "a-2 ブランク" '○
End If
If IsNull(b) = True Then
Debug.Print "b-2 null" '×
End If
If IsEmpty(c) = True Then
Debug.Print "c-2 empty" '○
End If

a = "": b = "": c = ""
If a = "" Then
Debug.Print "a-3 ブランク" '○
End If
If IsNull(b) = True Then
Debug.Print "b-3 null" '×
End If
If IsEmpty(c) = True Then
Debug.Print "c-3 empty" '×
End If

a = Null: b = Null: c = Null
If a = "" Then
Debug.Print "a-4 ブランク" '×
End If
If IsNull(b) = True Then
Debug.Print "b-4 null" '○
End If
If IsEmpty(c) = True Then
Debug.Print "c-4 empty" '×
End If

'件数

MsgBox Me.Count

DoCmd.GoToRecord , , acLast
lnglast = Me.CurrentRecord
DoCmd.GoToRecord , , acFirst

'コマンドバー列挙

Dim CmdBar As Object
For Each CmdBar In Application.CommandBars
Debug.Print CmdBar.Index, CmdBar.Name
Next
Debug.Print

'SGN

数値の正負を調べます。戻り値は、数値が正の数のときは 1、
0 のときは 0、負の数のときは -1 となります。

SGN(数値)

数値正負を調べる数値を指定します。
使用例
SIGN(10) = 1
SIGN(4-4) = 0
SIGN(-0.00001) = -1

'データ件数

Option Compare Database
Option Explicit

Dim db As DAO.Database
Dim tb As DAO.Recordset
Dim tbldef As DAO.TableDef
Dim strsql As String
Dim strdata As String

Private Sub cmdAll_Click()
On Error GoTo ErrHandler
    strdata = ""
    Me.lblTBL = ""
    Set db = CurrentDb
    For Each tbldef In db.TableDefs
        If Left(tbldef.Name, 4) = "MSys" Then
        Else
            Call dataCnt(tbldef.Name)
        End If
    Next
    db.Close
    Set db = Nothing
    Me.lblTBL = strdata
    MsgBox "完了 " & Format(Now(), "HH:MM:SS")
    Exit Sub
ErrHandler:
    MsgBox Err.Number & "-" & Err.Description
    Exit Sub
End Sub

Sub dataCnt(strtbl As String)
On Error GoTo ErrHandler
    strsql = "SELECT COUNT(*) as 件数 FROM " & strtbl
    Set tb = db.OpenRecordset(strsql)
    If tb.EOF Then
    Else
        strdata = strdata & strtbl & " = " & tb!件数 & vbCrLf
    End If
    tb.Close
    Set tb = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Number & "-" & Err.Description
    Exit Sub
End Sub

'DoCmd

DoCmd.OpenReport gstrDocName, acPreview, , gstrLinkCriteria, acDialog
DoCmd.Close acReport, rptName, acSaveYes
DoCmd.Close acReport, rptName, acSaveNo

'Nz

Nz 関数は、バリアント型 (Variant) の変数が Null 値である場合、0、長さ 0 の文字列 ("")、
または別の特定の値を返します。たとえば、この関数を使用して、Null 値を別の値に変換し、
式が Null 値に評価されないようにします。

'レプリカ

Sub MakeAdditionalReplica()
Dim dbs As DATABASE
Set dbs = DBEngine(0).OpenDatabase("D:\DOWN\xxx.mdb")
dbs.MakeReplica "D:\DOWN\xxx_rep.mdb", dbRepMakeReadOnly
dbs.Close
MsgBox "end"
End Sub

Sub SynchronizeDBs()
Dim dbs As DATABASE
Set dbs = DBEngine(0).OpenDatabase("D:\DOWN\xxx.mdb")
dbs.Synchronize "D:\DOWN\xxx_rep.mdb", dbRepImpExpChanges
dbs.Close
MsgBox "end"
End Sub

'カレントパス

txtpath = CurrentDb.Name
Application.CurrentProject.path

'実行時エラーを生成します

Err.Raise メソッド

'一覧形式連結型画面

ctrl+7で上記と同じ内容をコピー

'データベースウィンドウコントロール

'DoCmd.SelectObject acForm, , True 'データベースウィンドウを最小化する
'DoCmd.Minimize

'DoCmd.SelectObject acForm, , True 'データベースウィンドウを元に戻す
'DoCmd.Restore

'コンボ表示

With CodeContextObject
If (IsNull(.cboxxx)) Then
SendKeys "{f4}", False
End If
End With

'ShowUser mdb

Sub ShowUserRosterMultipleUsers()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    'Set cn = CurrentProject.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data
Source=G:\sic\vd\data\vd_dat.mdb"
    cn.Open
    Set rs = cn.OpenSchema(adSchemaProviderSpecific, ,
"{947bb102-5d43-11d1-bdbf-00c04fb92675}")
    Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, "",
rs.Fields(2).Name, rs.Fields(3).Name
    While Not rs.EOF
        Debug.Print rs.Fields(0), rs.Fields(1), rs.Fields(2), rs.Fields(3)
        rs.MoveNext
    Wend
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
End Sub

'レポートで詳細欄に表示する行数を設定する方法

'ツールボックスの [テキストボックス] ツールをクリックして、
'"詳細" セクションにテキストボックスコントロールを 1 つ配置します。
プロパティ設定値
名前 txtCount
可視いいえ
コントロールソース =1
集計実行グループ全体
'ツールボックスの [改ページ] ツールをクリックして、
'"詳細" セクションの最下部に改ページコントロールを配置し、名前を bpage とします
。
'1 ページの表示レコード件数を 20 件にしています。
If Me!txtCount Mod 20 = 0 Then
Me!bpage.Visible = True
Else
Me!bpage.Visible = False
End If

'次の IsKanji プロシージャでは、引数の文字列の種類を判断します。
2 バイト文字'だけの場合は -1 を、1 バイト文字だけの場合は 1 を、
混在している場合には 0'を返します。

Function IsKanji(strUnicode As String)
Dim strANSI As String
Dim lchar As Integer, lbyte As Integer

strANSI = StrConv(strUnicode, vbFromUnicode)
lchar = Len(strUnicode)
lbyte = LenB(strANSI)
If lchar * 2 = lbyte Then
IsKanji = -1
ElseIf lchar = lbyte Then
IsKanji = 1
Else
IsKanji = 0
End If
End Function

'宛名ラベルで同じレコードを連続して複数印刷する方法

'詳細セクションに非連結のテキストボックスを追加作成します。
プロパティ : 設定値
名前 : CNT
可視 : いいえ
Private Sub 詳細_Format(Cancel As Integer, FormatCount As Integer)
Dim 指定枚数 As Integer
指定枚数 = 4 '出力する回数を設定
If IsNull([cnt]) Then [cnt] = 1
If [cnt] <> 指定枚数 Then
Me.NextRecord = False
Me.MoveLayout = True
Me.PrintSection = True
End If
End Sub

Private Sub 詳細_Print(Cancel As Integer, PrintCount As Integer)
Dim 指定枚数 As Integer
指定枚数 = 4 '出力する回数を設定
If [cnt] <> 指定枚数 Then
[cnt] = [cnt] + 1
Else
[cnt] = 1
End If
End Sub

'コンボの名称を取得し、該当分のみ表示する

Private Sub cboid_AfterUpdate()
If IsNull(Me.cboid) Or Me.cboid = "" Then
MsgBox "TBLIDを選択してください。", vbInformation, gstrtitle
Me.cboid.SetFocus
Exit Sub
End If
Me.txttblname = Me.cboid.Column(1)
Me.Filter = "[TBLID] = '" & Me.cboid & "'"
Me.FilterOn = True
End Sub

'コンボを最新状態にする

Private Sub cboid_Enter()
cboid.Requery
End Sub

'リストボックス２つコントロール

'クリア
For i = 0 To Me.lst1.ListCount - 1
Me.lst1.Selected(i) = False
Next i
Me.lst2.RowSource = ""
'ＡＬＬセット
For i = 0 To Me.lst1.ListCount - 1
Me.lst1.Selected(i) = True
Next i
'部分セット
Dim strItems As String
strItems = ""
For i = 0 To Me.lst1.ListCount - 1
If Me.lst1.Selected(i) Then
strItems = strItems & Me.lst1.Column(0, i) & ";" & Me.lst1.Column(1, i) & ";" & Me.lst1.Column(2, i) & ";"
End If
Next i
Me.lst2.RowSource = ""
Me.lst2.RowSource = strItems

'キャンセル

Private Sub Form_BeforeUpdate(Cancel As Integer)
Cancel = True
DoCmd.CancelEvent

'入力の状態のチェック

Me.Dirty

'レコードコントロール

'キャンセル
DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
'新規
DoCmd.GoToRecord , , acNewRec

'保存
Me.Filter = "[相手先]='" & Me.相手先 & "'"
Me.FilterOn = True
DoCmd.Requery

'DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70

'進む
DoCmd.GoToRecord , "FS_Aite_v", acNext
Me.Filter = "[TBLID]='" & Forms![FS_Free_v]![TBLID] & "'" & " AND " & "[KEY]='" & Forms![FS_Free_v]![KEY] & "'"
Me.FilterOn = True
'戻る
DoCmd.GoToRecord , "Fs_Aite_v", acPrevious
Me.Filter = "[TBLID]='" & Forms![FS_Free_v]![TBLID] & "'" & " AND " & "[KEY]='" & Forms![FS_Free_v]![KEY] & "'"
Me.FilterOn = True

'フィルタ

Me.Filter = "項目 Like '" & Me.txtname & "*'"
Me.FilterOn = True

'最後ま線を引く

'レベル１
Private Sub グループヘッダー0_Format(Cancel As Integer, FormatCount As Integer)
i = 0
j = DCount("*", "Q_All_invoice_r")
End Sub
'レベル１、レベル２
Private Sub グループヘッダー1_Format(Cancel As Integer, FormatCount As Integer)
i = 0
j = DCount("*", "Q_All_invoice_r", "[様]=Reports![R_All_invoice]![様]")
End Sub
Private Sub 詳細_Format(Cancel As Integer, FormatCount As Integer)
i = i + 1
Me.send.Visible = False
If i Mod 25 = 0 Then
If i < j Then '改ページしてもまだある
Me![bpage].Visible = True
Call visi(True)
Me.send.Visible = True
ElseIf i = j Then 'ｊｕｓｔで終わり
Call visi(True)
Else 'Dummy out
Call visi(False)
End If
Else
Me![bpage].Visible = False
If i < j Then 'line out
Me.NextRecord = True
Call visi(True)
ElseIf i = j Then 'Last out
Me.NextRecord = False
Call visi(True)
Else 'Dummy out
Me.NextRecord = False
Call visi(False)
End If
End If
End Sub

Private Sub visi(boltf As Boolean)
Me.txt.Visible = boltf
End Sub

'クローズ

Private Sub cmdmenu_Click()
On Error Resume Next
If Me.Dirty Then
Select Case MsgBox("変更を保存しますか？", vbYesNoCancel, gstrtitle)
Case 6 'はい
Case 7 'いいえ
Case 2 'キャンセル
Exit Sub
End Select
End If
DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
DoCmd.Close acForm, "F_xxx"
DoCmd.Close acForm, "F_xxx_v"
DoCmd.Close
Exit_cmdmenu_Click:
Exit Sub
Err_cmdmenu_Click:
MsgBox gstrerrmsg & Err.Description, vbCritical, gstrtitle
Resume Exit_cmdmenu_Click
End Sub

'終了

Private Sub cmdend_Click()
If MsgBox("終了しますか？", vbYesNo + vbDefaultButton2, gstrtitle) = vbYes Then
'CloseCurrentDatabase
DoCmd.Quit 'Application.Quit
End If
End Sub

'メッセージの設定

Private Sub Form_Delete(Cancel As Integer)
On Error GoTo Err_Form_Delete
DoCmd.SetWarnings False
If MsgBox("削除しますか？", vbYesNo, gstrtitle) = vbNo Then
Cancel = True
Exit Sub
End If
Exit_Form_Delete:
DoCmd.SetWarnings False
Exit Sub
Err_Form_Delete:
MsgBox gstrerrmsg & Err.Description, vbCritical, gstrtitle
Resume Exit_Form_Delete
End Sub

'更新前にセット

Private Sub Form_BeforeUpdate(Cancel As Integer)
Me.更新者 = [Forms]![F_Menu]![txtman]
Me.更新日時 = Now()
End Sub

'乱数

Dim strjumbo As String
Randomize '乱数発生ルーチンを初期化します。
i = Int((5 * Rnd) + 1) '1 から 6 までの乱数を発生させます。
Select Case i
Case 1
strjumbo = "ぶぅ～ん"
Case 2
strjumbo = "きぃ～ん"
Case 3
strjumbo = "ごぉ～ん"
Case 4
strjumbo = "うぃ～ん"
Case 5
strjumbo = "あぃ～ん"
Case Else
strjumbo = "・・・"
End Select
MsgBox strjumbo, vbInformation

'メニュー表示

gstrDocName = ""
gstrLinkCriteria = ""
gstrDocName = "F_Menu"
DoCmd.OpenForm gstrDocName, , , gstrLinkCriteria
With Forms![F_Menu]
![txtman] = UCase(Me.txtman)
![txtbdman] = UCase(strbdman)
![txtname] = strname
![lbllink].Caption = strlink
![lbllink].HyperlinkAddress = strurl
End With
DoCmd.Close acForm, "F_Logon"

'AutoExec

アクション　フォームを開く

'入力規正

Len([txtpass])=4

'項目の変数化　Forms("xxxF")("txtAAA" & Forms![xxx]![txtXXX]) = Me.txtTotal　Me.Controls("txtxx" & i)

Set db = CurrentDb
gstrsql = "SELECT CHA2 FROM T_FREE "
Set rs = db.OpenRecordset(gstrsql & gstrwhere)
i = 1
Do Until rs.EOF
With rs
If IsNull(!CHA2) Then
Else
Me("FIE" & CStr(i)) = !CHA2
End If
rs.MoveNext
Me("txtno" & CStr(i)) = Format(i, "00")
i = i + 1
End With
Loop
rs.Close
Set rs = Nothing
'ｄｂｅｎｄ
db.Close
Set db = Nothing

'各コントロールに対して、元の値を復元します

Sub btnUndo_Click()
Dim ctlC As Control
For Each ctlC In Me.Controls
If ctlC.ControlType = acTextBox Then
ctlC.Value = ctlC.OldValue
End If
Next ctlC
End Sub

'リフレッシュ

Forms!FS_Free_v.Form.Refresh

'日を求める

'前月
getstaymd = DateSerial(Year(Date), Month(Date) - 1, 1)
'前月末
getendymd = DateSerial(Year(Date), Month(Date), 1) - 1

'プロテクト

Private Sub protect(ctlitem As Control)
ctlitem.Locked = True
ctlitem.Enabled = False
ctlitem.BackStyle = 0
ctlitem.SpecialEffect = 0
ctlitem.BorderStyle = 0
End Sub

'アンプロテクト

Private Sub protect1(ctlitem As Control)
ctlitem.Locked = False
ctlitem.Enabled = True
ctlitem.BackStyle = 1
ctlitem.SpecialEffect = 2
ctlitem.BorderStyle = 1
End Sub

'入力チェック

Public Sub LimitFieldSize(KeyAscii, MAXLENGTH)
Dim C As Control
Dim CLen As Integer
Set C = Screen.ActiveControl
'印刷可能でない文字が入力された場合は終了します。
If KeyAscii < 32 Then Exit Sub
'既に入力されている文字を範囲選択してから書き換えた場合は終了します。
If C.SelLength > 0 Then Exit Sub
' 入力された文字の長さを取得します。
CLen = Len(C.Text & "") + 1
'
If C.SelStart + 1 > CLen Then CLen = C.SelStart + 1
'文字列の長さが指定した文字数よりも大きい場合はｍ警告音を鳴らします。
If CLen > MAXLENGTH Then
Beep
KeyAscii = 0
End If
End Sub

'Empty キーワード
'キーワード Empty はバリアント型 (Variant) の 1 つで、
'変数に格納されている値が初期化されていないことを示します。

'初期値

Forms![F_xxx]![F_xxx_J]![項目].RowSourceType = "Table/Query"
Forms![F_xxx]![F_xxx_J]![項目].RowSource = "Q_Aite_pd"
Forms![F_Invoice]![グループ].DefaultValue = """" & strgrp & """"

'マウスで反転

Private Sub NO_Click()
'テキスト
Call TextCntl(Me.NO, 25)
End Sub
Private Sub NO_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'コンボ
If IsNull(Me.NO) Or Me.NO = "" Then
Exit Sub
End If
Call TextCntlcbo(Me.NO, 40)
End Sub
'テキスト版
Public Sub TextCntl(textdata As TextBox, lonlen As Long)
On Error Resume Next
textdata.SelStart = 0
textdata.SelLength = lonlen
End Sub
'コンボボックス版
Public Sub TextCntlcbo(textdata As ComboBox, lonlen As Long)
textdata.SelStart = 0
textdata.SelLength = lonlen
End Sub

'IsLoaded プロパティ
'AccessObject が現在ロードされているかどうかを示します

'作業ウィンドウ固定を解除

section.Modal = False

'背景色を変える

Public Sub BackColorset(section As Form)
Select Case Forms![F_Menu]![txtxxx]
Case "xx"
section.section(1).BackColor = 10223615
section.section(0).BackColor = 10223615
Case "yy"
section.section(1).BackColor = 16777139
section.section(0).BackColor = 16777139
Case Else
End Select
End Sub

'並べ替え

DoCmd.Requery ""
Forms![F_Invoice_v]![txtnendo].SetFocus
Forms![F_Invoice_v].OrderBy = "[年度] DESC,[ナンバー] DESC"
Forms![F_Invoice_v].OrderByOn = True

コンスタント

'Public Const gstrerrmsg = "重大エラーが発生しました。" & _
vbCrLf & "維持担当者に連絡してください。" & vbCrLf & "<<エラー内容>>" & vbCrLf

'最適化 /compact

Private Sub cmdcomp_Click()
On Error GoTo Err_cmdcomp_Click
If MsgBox("最適化を行ないますか？", vbYesNo, gstrtitle) = vbYes Then
Dim lonflen As Long
Dim strldb As String
lonflen = Len(Me.txtdpass)
If Dir(Me.txtdpass) <> "" Then
strldb = Left(Me.txtdpass, lonflen - 3) & "ldb"
If Dir(strldb) <> "" Then
MsgBox "他の" & gstrtitle & "(" & Me.txtdpass & ")を終了させてください。", vbInformation, gstrtitle
Exit Sub
End If
Else
MsgBox Me.txtdpass & "が存在しません。", vbInformation, gstrtitle
Exit Sub
End If
Dim returnvalue As String
Dim strbak As String
Dim strdnew As String
Screen.MousePointer = 11
returnvalue = VarType(SysCmd(acSysCmdSetStatus, "最適化中です。しばらくおまち下さい。"))
lonflen = Len(Me.txtdpass)
strdnew = Left(Me.txtdpass, lonflen - 3) & "NEW"
DBEngine.CompactDatabase Me.txtdpass, strdnew '最適化
Kill Me.txtdpass
Name strdnew As Me.txtdpass
MsgBox "最適化が完了しました。", vbInformation, gstrtitle
End If
Exit_cmdcomp_Click:
returnvalue = SysCmd(acSysCmdClearStatus)
Screen.MousePointer = 0
Exit Sub
Err_cmdcomp_Click:
MsgBox gstrerrmsg & Err.Description, vbCritical, gstrtitle
Resume Exit_cmdcomp_Click
End Sub

'印刷

Private Sub cmdpre_Click()
On Error GoTo Err_cmdpre_Click
gstrDocName = ""
gstrLinkCriteria = ""

Select Case Me.cbomst.ListIndex
Case 0
gstrDocName = "R_xxxx"
gstrLinkCriteria = "[xxxxx Not Like '00*' AND [xxxx]<='9999999'"
Case Else
End Select
If gstrDocName <> "" Then
If Me.optpre = True Then
DoCmd.OpenReport gstrDocName, acPreview, , gstrLinkCriteria
Else
DoCmd.OpenReport gstrDocName, acViewNormal, , gstrLinkCriteria
End If
End If
Exit_cmdpre_Click:
Exit Sub
Err_cmdpre_Click:
'対象データが無い時
If Err.Number = 2501 Then Resume Exit_cmdpre_Click
MsgBox gstrerrmsg & Err.Description, vbCritical, gstrtitle
Resume Exit_cmdpre_Click

End Sub
'対象データが無い時
Private Sub Report_NoData(Cancel As Integer)
MsgBox "対象データがありません。", vbInformation, gstrtitle
DoCmd.CancelEvent
End Sub
'プレビュー最大
Private Sub Report_Open(Cancel As Integer)
'DoCmd.SelectObject acReport, , True
DoCmd.Maximize
'DoCmd.SelectObject acReport, , True
'DoCmd.Restore
End Sub

'クロス集計で'[Forms]![frm_xxxx]![txtitem]'を有効なフィールド名、
または式として認識できません。　パラメータを使用

ファイル選択ダイアログ

「参照設定」で「Microsoft Shell Controls And Automation」にチェックしてください。
'ファイル選択ダイアログ
Sub Sample()
    Dim objShell As New Shell
    Dim objFolder As Shell32.Folder
    Const strTitle = "フォルダを選択してください。"
    'フォルダー参照に設定
    Const lngRef = &H1
    'ルートフォルダーをデスクトップに設定
    '5でMy Documents、6でFavoritesなど
    Const fldRoot = &H0
    Set objFolder = _
            objShell.BrowseForFolder(0, _
                strTitle, lngRef, fldRoot)
    Set objShell = Nothing
    'フォルダー名を取出す
    Dim strMsg as String
    If objFolder Is Nothing Then 'キャンセルチェック
        strMsg = "キャンセルテスト"
    Else
        If objFolder.ParentFolder Is Nothing Then
            strMsg = "選択されたのは[ルート(デスクトップ)]です"
        Else
            strMsg = "選択されたのは[" & objFolder.Items.Item.Path & "]です"
        End If
    End If
    MsgBox strMsg
End Sub

「参照設定」で「Microsoft Office xx Object Library」にチェックしてください。
'ファイル選択ダイアログ
Public Function SelectFile_FileDialog() As String
    Dim dlgfolder As FileDialog
    'ダイアログのタイトル
    Application.FileDialog(msoFileDialogFilePicker).Title = "ファイルを選択してください"
    '初期のフォルダ
    Application.FileDialog(msoFileDialogFilePicker).InitialFileName ="d:\down\"
    Application.FileDialog(msoFileDialogFilePicker).Filters.Add "ＣＳＶ形式のファイル (*.CSV)", "*.csv", 1
    '一つのファイルのみ選択可能
    Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect =False
    If Application.FileDialog(msoFileDialogFilePicker).Show = -1 Then
        'ファイルが選択された
        SelectFile_FileDialog =Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
    Else
        SelectFile_FileDialog = ""
    End If
End Function

'ファイル選択ダイアログ
Sub Sample()
    Dim Daialog_Box As Object
    Dim File_Name As Variant
    Dim i As Long
    Set Daialog_Box = CreateObject("Excel.Application")
    Daialog_Box.Application.Visible = False
    File_Name = Daialog_Box.Application.GetOpenFilename("ＣＳＶ形式のファイ
ル (*.CSV),*.CSV", , "保存している場所を選択してください")
    Daialog_Box.Application.Quit
    Set Daialog_Box = Nothing
    If File_Name = False Then Me.テキスト1 = Me.テキスト1: GoTo
End_Function
    For i = Len(File_Name) To 1 Step -1
        If Mid(File_Name, i, 1) = "\" Then Exit For
    Next i
    Me.テキスト1 = Left(File_Name, i - 1)
End_Function:
End Sub
「参照設定」で「Microsoft Office xx Object Library」にチェックしてください。
Sub setFileDialog()
    Dim fDialog As Office.FileDialog
    Dim varfile As Variant

    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .AllowMultiSelect = False
        .Title = ""
        .Filters.Clear
        .Filters.Add "mdb File", "*.mdb"
        .InitialFileName = ""
        If .Show = True Then
            For Each varfile In .SelectedItems
                Me.lblpath.Caption = varfile
            Next
        Else
            Exit Sub
        End If
    End With
    Set fDialog = Nothing
End Sub

'Ｄ関数？

DLookup("Dパス", "Q_Text")
DCount("*", "Q_xxxx_v")

'一括コントロール制御

Public Sub chgFormZero(strFormName As String)
    Dim frm As Form
    Dim ctl As Object
    'フォーム名からフォームを取得する
    Set frm = Forms(strFormName)
    For Each ctl In frm.Controls
        'If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then
        If ctl.Name = "txt○○１" Or ctl.Name = "txt○○２" Then
        Else
            If ctl.ControlType = acTextBox Then
                If chkBlank(ctl) = True Then
                    ctl = 0
                End If
            End If
        End If
    Next ctl
    Set frm = Nothing
End Sub

'DAOアクセス
'参照設定 Microsoft DAO 3.6 Object Library

Public db As DAO.Database
Public rs As DAO.Recordset
Public qd As DAO.QueryDef

Public gstrsql As String
Public gstrwhere As String
'select
'ｄｂｓｅｔ
Set db = CurrentDb
gstrsql = "SELECT Max(T_CLAIM.ナンバー) AS ナンバーの最大 FROM T_CLAIM "
gstrwhere = "WHERE グループ='" & strgrp & "' AND 輸入輸出='" & strie & "' AND 年度='" & strnendo & "'" & _
" GROUP BY T_CLAIM.グループ, T_CLAIM.輸入輸出, T_CLAIM.年度"
Set rs = db.OpenRecordset(gstrsql & gstrwhere)
If rs.EOF Then
claimnoget = "00001"
Else
With rs
claimnoget = Format(CLng(!ナンバーの最大) + 1, "00000")
End With
End If
rs.Close
Set rs = Nothing
'ｄｂｅｎｄ
db.Close
Set db = Nothing
'UPDATE
Set db = CurrentDb()
gstrsql = "UPDATE T_INVOICE SET クレーム年度 = '" & "" & "',クレームナンバー = '" & _
"" & "',更新者 = '" & [Forms]![F_Menu]![txtman] & "',更新日時 = '" & Now() & "' " & _
"WHERE グループ='" & Me.グループ & "' AND 輸入輸出='" & Me.輸入輸出 & "' AND 年度='" & _
Me.インボイス年度 & "' AND ナンバー='" & Me.インボイスナンバー & "';"
db.Execute gstrsql
db.Close
Set db = Nothing
'FETCH
Set db = CurrentDb
gstrsql = "SELECT CHA1,CHA3,CHA4,CHA5,CHA6,CHA7 FROM T_FREE "
gstrwhere = "WHERE TBLID='U020' ORDER BY KEY"
Set rs = db.OpenRecordset(gstrsql & gstrwhere)
Do Until rs.EOF
With rs
strritu(i) = IIf(IsNull(!CHA7), "000", !CHA7)
rs.MoveNext
End With
Loop
rs.Close
Set rs = Nothing
'ｄｂｅｎｄ
db.Close
Set db = Nothing
'Query
Set db = CurrentDb
Set qd = db.QueryDefs("Q_Claim_nendo_count")
qd.Parameters!p1 = Me.txtgrp
qd.Parameters!p2 = Me.txtie
Set rs = qd.OpenRecordset()
Dim txthit As String
txthit = "0"
Do Until rs.EOF
With rs
Me("txt件数" & CStr(i)) = !件数
Me("txt件数" & CStr(i)).Visible = True
.MoveNext
End With
Loop

rs.Close
Set rs = Nothing
qd.Close
Set qd = Nothing
db.Close
Set db = Nothing

'レポートの出力先のプリンタを変更する方法

概要レポートを複数のプリンタに切り替えて印刷するような場合には、
レポートの「ページ設定」で指定されたプリンタを変更する必要があります。
ここでは、変更する出力先に設定されているダミーレポートを作成しておき、
そのレポート内のプロパティ値を印刷したいレポートに代入する方法を説明します。
内容以下の手順はフォームのコマンドボタンをクリックすることにより、
レポートの出力先のプリンタを変更する方法です。

印刷するレポートを作成し "印刷用" という名前で保存します。
特に「ページ設定」を変更しない限り通常使うプリンタが設定されています。
ダミーレポートを作成します。内容は何でも結構です。
例、無地レポートを作成しラベルコントロールを 1 個配置、など。

「ページ設定」で [その他のプリンタ] を選択し切り替えたいプリンタを
設定しておきます。
「ページ設定」の他の設定項目はすべて 1. の "印刷用" レポートと同じにし、
"ダミー" という名前でレポートを保存します。
新規モジュールを作成し以下のプロシージャを記述します。
Public Function SetPrtDevPrt1toPrt2(Report1 As String, Report2 As String)
DoCmd.OpenReport Report1, acDesign
DoCmd.OpenReport Report2, acDesign
If Not IsNull(Reports(Report1).PrtDevNames) Or Not _
IsNull(Reports(Report1).PrtDevMode) Or Not IsNull(Reports(Report2) _
.PrtDevNames) Or Not IsNull(Reports(Report2).PrtDevMode) Then
Reports(Report1).Painting = False
Reports(Report2).Painting = False
Reports(Report2).PrtDevMode = Reports(Report1).PrtDevMode
Reports(Report2).PrtDevNames = Reports(Report1).PrtDevNames
Reports(Report1).Painting = True
Reports(Report2).Painting = True
DoCmd.SetWarnings False
DoCmd.SelectObject acReport, Report1
DoCmd.DoMenuItem 7, acFile, 2
DoCmd.SelectObject acReport, Report2
DoCmd.DoMenuItem 7, acFile, 2
DoCmd.SetWarnings True
End If
DoCmd.Close acReport, Report1
DoCmd.Close acReport, Report2
End Function

新規無地フォームを作成し、コマンドボタンを 1 つ配置します。
コマンドボタンの "クリック時" プロパティに以下のように指定します。
=SetPrtDevPrt1toPrt2("ダミー" , "印刷用")

フォームを保存し、フォームビューに切り替えコマンドボタンをクリックします。
この結果、"印刷用" レポートの「ページ設定」を確認すると、
"ダミー" レポートで設定したプリンタに変更されています。

'プリンタ設定のプログラミング　其の一　関連

Sub PrtDevModeSet(ByVal rptName As String)
Dim rpt As Report
DoCmd.OpenReport rptName, acDesign ' デザインビューでレポートを開きます。
Set rpt = Reports(rptName)
With rpt.Printer
' MsgBox .BottomMargin
' MsgBox .ColorMode
' MsgBox .BottomMargin
' MsgBox .Copies
' MsgBox .DataOnly
' MsgBox .DefaultSize
' MsgBox .DeviceName
' MsgBox .DriverName
' MsgBox .Duplex
' MsgBox .ItemLayout
' MsgBox .ItemsAcross
' MsgBox .ItemSizeHeight
' MsgBox .ItemSizeWidth
' MsgBox .LeftMargin
' MsgBox .Orientation
' MsgBox .PaperBin
' MsgBox .PaperSize
' MsgBox .Port
' MsgBox .PrintQuality
' MsgBox .RightMargin
' MsgBox .RowSpacing
' MsgBox .TopMargin
' .BottomMargin = 284
' .ColorMode = 1
' .BottomMargin = 284
' .Copies = 1
' '.DataOnly = False
' .DefaultSize = False
' '.DeviceName
' '.DriverName
' '.Duplex = 1
' .ItemLayout = 1953
' '.ItemsAcross = 1
' .ItemSizeHeight = 13319
' .ItemSizeWidth = 11002
' .LeftMargin = 454
' .Orientation = 1
' '.PaperBin = 315
' .PaperSize = 122
' '.Port
' '.PrintQuality = 180
' .RightMargin = 284
' .RowSpacing = 0
' .TopMargin = 284
' Exit Sub
.PaperSize = acPRPSTabloid
'用紙の向きを縦に設定
.Orientation = acPRORLandscape 'acPRORPortrait 縦　acPRORLandscape　横
'印刷部数を 1 部に設定
.Copies = 1
'給紙トレイを下段に設定
'.PaperBin = acPRBNLower
'.DefaultSize = False
'.ItemSizeHeight = 2349
'.ItemSizeWidth = 1940
'印刷するページの上の余白を 5.01mm に設定
.TopMargin = Round(5.01 * 56.7, 2)
'印刷するページの下の余白を 5.01mm に設定
.BottomMargin = Round(5.01 * 56.7, 2)
'印刷するページの右の余白を 5.01mm に設定
.RightMargin = Round(5.01 * 56.7, 2)
'印刷するページの左の余白を 8.01mm に設定
.LeftMargin = Round(8.01 * 56.7, 2)
End With
'レポートを保存します。
DoCmd.Close acReport, rptName, acSaveYes
Set rpt = Nothing
End Sub

'プリンタ設定のプログラミング　其の二

PrtDevMode プロパティ
関連項目対象使用例アプリケーション情報[印刷] ダイアログボックスでフォームまたはレポートに対して
指定された、印刷のためのデバイスモードの情報を設定します。
値の取得および設定が可能です。バリアント型 (Variant) の値を使用します。

expression.PrtDevMode
expression 必ず指定します。このトピックの [対象] をクリックして表示される
Access オブジェクトのうちの 1 つを返すオブジェクト式を指定します。

解説
PrtDevMode、PrtDevNames、および PrtMip プロパティの詳細については、
『Win32 Software Development Kit』を参照してください。

設定値は、Win32 Software Development Kit で定義されている DEVMODE 構造体を複製する構造体です。
PrtDevMode プロパティのメンバーの詳細については、『Win32 Software Development Kit』を参照してください。

PrtDevMode プロパティのメンバーは次のとおりです。

メンバー内容
DeviceName 最大 32 バイトの文字列で、ドライバがサポートする装置の名前を示します。
たとえば、指定されたプリンタが Hewlett-Packard LaserJet IIISi の場合は、
"HP LaserJet IIISi" が装置名です。各プリンタドライバには、固有の文字列の名前が付いています。
SpecVersion 『Win32 Software Development Kit』の DEVMODE
構造体のバージョン番号を指定する整数型 (Integer) の値です。
DriverVersion プリンタドライバの開発者によって割り当てられた
プリンタドライバのバージョン番号を指定する整数型 (Integer) の値です。
Size DEVMODE 構造体のサイズをバイト数で指定した整数型 (Integer) の値です。
この値には、この構造体の後に任意に続けることができる、装置独自のデータを格納する
dmDriverData メンバーのサイズは含まれません。データのデバイス依存の部分のみがアプリケーションによって
操作される場合は、このメンバーを使って、バージョンの違いを考慮せずに、構造体のサイズを調べることができます。
DriverExtra 装置独自のデータを格納するオプションの dmDriverData メンバーのサイズを、
バイト数で指定した整数型 (Integer) の値です。このメンバーは、この構造体の後ろに続けることができます。
装置独自の情報がアプリケーションによって使われない場合は、このメンバーに 0 を設定します。
Fields DEVMODE 構造体の残りのメンバーのうち、初期化されているメンバーを示す長整数型 (Long) の値です。
Orientation 用紙の方向を指定する整数型 (Integer) の値です。1 (縦方向) または 2 (横方向) を指定できます。
PaperSize 印刷する用紙のサイズを指定する整数型 (Integer) の値です。
このメンバーに 0 から 256 までを設定した場合は、用紙の長さと幅が、それぞれ PaperLength メンバーと
PaperWidth メンバーによって指定されます。
それ以外の値を設定した場合は、PaperSize メンバーに、あらかじめ定義された値を設定できます。
使用可能な値については、ここをクリックしてください。
PaperLength 1/10 ミリ単位で用紙の長さを示す整数型 (Integer) の値です。
独自の用紙サイズに対して、または多様な用紙サイズに印刷できるドット
マトリックス方式のプリンタなどの装置に対して PaperSize メンバーで指定された用紙の長さよりも、
このメンバーの値が優先します。
PaperWidth 1/10 ミリ単位で用紙の幅を指定する整数型 (Integer) の値です。
PaperSize メンバーで指定された用紙の幅よりも、このメンバーの値が優先します。
Scale 印刷の出力が縮小される因数を指定する整数型 (Integer) の値です。
見た目のページサイズは、scale/100 の因数で物理的なページサイズから縮小されます。
たとえば、Scale の値を 50 にした 8.5 x 11 インチのレターサイズの用紙には、
出力されるテキストとグラフィックスが元の高さと幅の半分であるので、
17 x 22 インチの用紙と同じ量のデータを含めることができます。
Copies 印刷装置が複数ページの複写をサポートしている場合は、部数を示す整数型 (Integer) の値です。
DefaultSource 用紙を送る既定のビンを指定する整数型 (Integer) の値です。
使用可能な値については、ここをクリックしてください。
PrintQuality プリンタの解像度を指定する整数型 (Integer) の値です。
指定できる値は 4 (高)、3 (中)、2 (低)、および 1 (ドラフト) です。
Color 整数型 (Integer) の値です。カラープリンタに対して、出力をカラーで印刷するかどうかを示します。
指定できる値は、1 (カラー) および 2 (モノクローム) です。
Duplex 整数型 (Integer) の値です。両面印刷できるプリンタに対して、出力が用紙の両面に印刷されるかどうかを示します。
指定できる値は、1 (片面)、2 (水平)、および 3 (垂直) です。
YResolution プリンタの y 軸の解像度をインチ当たりのドット数 (dpi) で指定する整数型 (Integer) の値です。
プリンタがこのメンバーを初期化する場合、PrintQuality メンバーは、プリンタの x 軸の解像度を dpi で示します。
TTOption TrueType フォントがどのように印刷されるかを示す整数型 (Integer) の値です。
使用可能な値については、ここをクリックしてください。
Collate 印刷部数が複数ある場合に、照合を行う必要があるかどうかを示す整数型 (Integer) の値です。
データはプリンタに 1 回だけ送られるので、照合を行わない方が、速く、効率的に印刷できます。
FormName 用紙のサイズを示す 16 字までの文字列です。たとえば、"レター" や "標準" があります。
Pad 将来のバージョン用にスペース、文字、値などを埋めるために使う長整数型 (Long) の値です。
Bits ディスプレイ装置のカラー解像度をピクセル当たりのビット数で示す長整数型 (Long) の値です。
PW 表示装置の表面 (画面またはプリンタ) の幅をピクセルで示す長整数型 (Long) の値です。
PH 表示装置の表面 (画面またはプリンタ) の高さをピクセルで示す長整数型 (Long) の値です。
DFI 装置の表示モードを示す長整数型 (Long) の値です。
DFR 特定のモードの表示装置の周波数を hertz (秒当たりのサイクル数) で示す長整数型 (Long) の値です。

メモ PrtDevMode プロパティを設定するには、Visual Basic を使用します。

このプロパティは、デザインビューでは値の取得および設定が可能です。他のビューでは値の取得のみ可能です。

注意プリンタドライバによって、DEVMODE 構造体の 94 バイトの直後に、装置独自のデータが追加されます。
したがって、前に解説した DEVMODE のデータが 94 バイトを超えないようにします。

ExtDeviceMode 関数をエクスポートするプリンタドライバのみが、DEVMODE 構造体を使います。

アプリケーションで、DC_PAPERS、DC_PAPERSIZE、および DC_PAPERNAMES の値を使って DeviceCapabilities 関数を呼び出し、
プリンタにサポートされる用紙のサイズと名前を取得できます。

TTOption メンバーの値を設定する前に、アプリケーションで DC_TRUETYPE の値を使って DeviceCapabilities 関数を呼び出し、
プリンタドライバの TrueType フォントの使い方を調べておく必要があります。

'----細かい解説は、PrtDevModeのヘルプを参照して下さい。
Private Type str_DEVMODE
strRGB As String * 94
End Type

Private Type type_DEVMODE
strDeviceName As String * 16 'ドライバがサポートする印刷装置の名前。
intSpecVersion As Integer '『Win32 Software Development Kit』の DEVMODE 構造体のバージョン番号
intDriverVersion As Integer 'プリンタドライバのバージョン
intSize As Integer 'DEVMODE 構造体のサイズをバイト数で指定
intDriverExtra As Integer '装置独自のデータ
lngFields As Long 'DEVMODE 構造体内でどのメンバが初期化されているかを示す長整数型 (Long) の値
intOrientation As Integer '用紙の方向。1 (縦方向) または 2 (横方向) 。
intPaperSize As Integer '印刷する用紙のサイズ。PrtDevModeヘルプ参照。
intPaperLength As Integer '1/10 ミリ単位で用紙の長さを示す整数型の値。PaperSizeより優先される。
intPaperWidth As Integer '1/10 ミリ単位で用紙の幅を示す整数型の値。PaperSizeより優先される。
intScale As Integer '印刷の出力が縮小される因数
intCopies As Integer '印刷部数
intDefaultSource As Integer '用紙を送る既定のビンを指定。PrtDevModeヘルプ参照。
intPrintQuality As Integer 'プリンタの解像度。 4 (高)、3 (中)、2 (低)、および 1 (ドラフト)。
intColor As Integer 'カラープリンタに対して、出力をカラー印刷の有無を指定。1 (カラー) および 2 (モノクローム) 。
intDuplex As Integer '両面印刷できるプリンタに対して両面印刷の有無を指定。1 (片面)、2 (水平)、および 3 (垂直) 。
intYResolution As Integer 'プリンタの y 軸の解像度をインチ当たりのドット数 (dpi) で指定
intTTOption As Integer 'TrueType フォントがどのように印刷されるかを示す。PrtDevModeヘルプ参照。
intCollate As Integer '印刷部数が複数ある場合に、照合を行う必要があるか。
strFormName As String * 16 '用紙のサイズを示す 16 字までの文字列
lngPad As Long '調整用。
lngBits As Long 'ディスプレイ装置のカラー解像度
lngPW As Long '表示装置の表面 (画面またはプリンタ) の幅
lngPH As Long '表示装置の表面 (画面またはプリンタ) の高さ
lngDFI As Long '装置の表示モード
lngDFr As Long '特定のモードの表示装置の周波数
End Type

Private Type str_PRTMIP
strRGB As String * 28
End Type

Private Type type_PRTMIP
intLeftMargin As Long
intTopMargin As Long
intRightMargin As Long
intBotMargin As Long
intDataOnly As Long
intWidth As Long
intHeight As Long
intFefaultSize As Long
intColumns As Long
intColumnSpacing As Long
intRowSpacing As Long
intItemLayout As Long
intFastPrint As Long
intDataSheet As Long
End Type

Sub PrtDevModeSet1(ByVal rptName As String)
Const DM_ORIENTATION = &H1
Dim DevString As str_DEVMODE
Dim Dm As type_DEVMODE
Dim strDevModeExtra As String
Dim rpt As Report
DoCmd.OpenReport rptName, acDesign ' デザインビューでレポートを開きます。
Set rpt = Reports(rptName)
If Not IsNull(rpt.PrtDevMode) Then
strDevModeExtra = rpt.PrtDevMode
DevString.strRGB = strDevModeExtra
LSet Dm = DevString
Dm.lngFields = Dm.lngFields Or DM_ORIENTATION ' フィールドを初期化します。
Dm.intCopies = 1 'フォームで指定された印刷部数を代入
'Dm.intPaperSize = 16 'フォームで指定された用紙サイズを代入
Dm.intPaperLength = 13.6 * 254
Dm.intPaperWidth = 11 * 254
Dm.intOrientation = 1 'フォームで指定された用紙向きを代入　縦
LSet DevString = Dm ' プロパティを更新します。
Mid(strDevModeExtra, 1, 94) = DevString.strRGB
rpt.PrtDevMode = strDevModeExtra

Const W_DOT = 567 ' cm換算ドット数
Dim PrtMipString As str_PRTMIP
Dim Pm As type_PRTMIP
PrtMipString.strRGB = rpt.PrtMip ' MIP構造体の取得
LSet Pm = PrtMipString
Pm.intLeftMargin = 0.8 * W_DOT ' マージン設定
Pm.intRightMargin = 0.5 * W_DOT
Pm.intTopMargin = 0.5 * W_DOT
Pm.intBotMargin = 0.5 * W_DOT
LSet PrtMipString = Pm
rpt.PrtMip = PrtMipString.strRGB
End If
Set rpt = Nothing
DoCmd.Close acReport, rptName, acSaveYes
End Sub

'マウスのホイール機能制御

Class Module: CMouseWheel
--------------------------------------------------------------------------
Option Compare Text
Option Explicit

Private frm As Object
Private intCancel As Integer
Public Event MouseWheel(Cancel As Integer)

Public Property Set Form(frmIn As Object)
Set frm = frmIn
End Property

Public Property Get MouseWheelCancel() As Integer
MouseWheelCancel = intCancel
End Property

Public Sub SubClassHookForm()
lpPrevWndProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, _
AddressOf WindowProc)
Set CMouse = Me
End Sub

Public Sub SubClassUnHookForm()
Call SetWindowLong(frm.hwnd, GWL_WNDPROC, lpPrevWndProc)
End Sub

Public Sub FireMouseWheel()
RaiseEvent MouseWheel(intCancel)
End Sub

Module:
--------------------------------------------------------------------------
Option Compare Text
Option Explicit

Public CMouse As CMouseWheel
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Const GWL_WNDPROC = -4
Public Const WM_MouseWheel = &H20A
Public lpPrevWndProc As Long

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Select Case uMsg
Case WM_MouseWheel
CMouse.FireMouseWheel
If CMouse.MouseWheelCancel = False Then
WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
End If
Case Else
WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
End Select
End Function

Module: Form
--------------------------------------------------------------------------
Option Compare Database
Option Explicit

Private WithEvents clsMouseWheel As CMouseWheel

Private Sub Form_Load()
Set clsMouseWheel = New CMouseWheel
Set clsMouseWheel.Form = Me.Form
clsMouseWheel.SubClassHookForm
End Sub

Private Sub Form_Close()
clsMouseWheel.SubClassUnHookForm
Set clsMouseWheel.Form = Nothing
Set clsMouseWheel = Nothing
End Sub

Private Sub clsMouseWheel_MouseWheel(Cancel As Integer)
MsgBox "You cannot use the mouse wheel to scroll records."
Cancel = True
End Sub

http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q308636&

'[ACC2003] Access 2003 ランタイムのセキュリティ警告について

a. デジタル署名を使用する

b. セキュリティレベルを変更する

a. デジタル署名を使用する
デジタル署名を使用することにより、セキュリティ警告のメッセージを非表示にします。

開発環境での操作
1. C:\Program Files\Microsoft Office\Office\SELFCERT.EXE
で任意の名前を付けデジタル署名を作成します。
2. Access 2003 を起動し、ランタイムとして配布するファイルを開きます。
3. [ツール] メニューの [マクロ] をポイントし、[Visual Basic Editor] をクリックします。
4. プロジェクトエクスプローラで、db1 プロジェクトを選択します。
5. [ツール] メニューの [デジタル署名] をクリックします。
6. [選択] をクリックし、証明書を選択してから [OK] を 2 回クリックします。
7. Visual Basic Editor を終了し、Access を閉じます。

ランタイム環境での操作
1. 上記の "開発環境での操作" で使用したファイルをランタイム環境へ配布します。
2. Access 2003 を起動し、ファイルを開きます。
3. "セキュリティ警告" 画面で、[詳細] をクリックします。
4. "デジタル署名の詳細" 画面で、[証明書の表示] をクリックします。
5. "証明書" 画面の "全般" タブの [証明書のインストール] をクリックします。
6. "証明書のインポートウィザード" で、[次へ] を 2 回クリックし、[完了] をクリックします。
7. "ルート証明書ストア" 画面で、[はい] をクリックし、[OK] を 3 回クリックします。
8. "セキュリティの警告" 画面で、[キャンセル] をクリックします。
9. 再度、Access 2003 を起動し、ファイルを開きます。
10. "セキュリティの警告" 画面で、"この発行元のファイルを常に信頼し、
自動的にファイルを開くにチェックを入れて、[開く] をクリックします。

b. セキュリティレベルを変更する
以下のコードを実行し、セキュリティ設定の画面を表示して、セキュリティレベルを "低" に
変更することにより、セキュリティ警告のメッセージを非表示にします。