Embedded Files
自分技術情報1
下記情報はOffice 365 Access x64版で動作確認しております。記述されているフォーム名、変数は自身の環境に置き換えてご利用ください。
画面デザインについて
・エンドユーザーの利用しているディスプレィの最適解像度に合わせてフルスクリーンでフォームを作成します。
・ポップアップウィンドウは極力利用しません。利用しているディスプレィがデュアルだった場合、別の画面に出る場合があり、
そのポップアップがあるとその処理 をしないと先に進めない為。 （個人的にポップアップウィンドウは好きではありません。）その為、画面に
収まりきらない場合は、タブウィンドウ又はサブフォームの大きさの随時変更などで対応します。
・保守がやり易いように他のツールと情報を共有するマスタを作成しています。
・マニュアル・仕様書はMicrosoft OneNoteを利用しております。
・x86版とx64版の両方で動作可能なように作成します。但し、ランタイム版は制約が多いため対応はしておりません。
自分技術情報1
下記情報はOffice 365 Access x64版で動作確認しております。記述されているフォーム名、変数は自身の環境に置き換えてご利用ください。
画面デザインについて
・エンドユーザーの利用しているディスプレィの最適解像度に合わせてフルスクリーンでフォームを作成します。
・ポップアップウィンドウは極力利用しません。利用しているディスプレィがデュアルだった場合、別の画面に出る場合があり、
そのポップアップがあるとその処理 をしないと先に進めない為。 （個人的にポップアップウィンドウは好きではありません。）その為、画面に
収まりきらない場合は、タブウィンドウ又はサブフォームの大きさの随時変更などで対応します。
・保守がやり易いように他のツールと情報を共有するマスタを作成しています。
・マニュアル・仕様書はMicrosoft OneNoteを利用しております。
・x86版とx64版の両方で動作可能なように作成します。但し、ランタイム版は制約が多いため対応はしておりません。
OneNote リンク：IMenuA
データシートを表示させる時データのサイズに合わせて横幅を自動設定するが特定の見出しのみ固定の列幅にする
Public Sub 列幅自動整列_01()
'列幅自動整列_02
Dim ctrl As Control
With Me![W750_関連マスタメンテナンス_FM_SUBF01]
.Requery
.Form.RowHeight = 312 'データシートの高さ 15.6 1=20
For Each ctrl In .Form.Controls
If ctrl.ControlType = acLabel Or ctrl.ControlType = acSubform Then GoTo 次項目
ctrl.ColumnWidth = -2
If InStr(ctrl.ControlSource, "マスタ内訳") > 0 Then ctrl.ColumnWidth = 4000
If InStr(ctrl.ControlSource, "テーブル名") > 0 Then ctrl.ColumnWidth = 4550
ctrl.ColumnHidden = True
If InStr(ctrl.ControlSource, "テーブル名") > 0 Then ctrl.ColumnHidden = False
'If InStr(Ctrl.ControlSource, "拡張機能システムのタイトル名") > 0 Then Ctrl.ColumnHidden = False
次項目:
Next ctrl
End With
End Sub
カレントフォームから別のフォームへの移動ボタン
カレントフォームから別のフォームへの移動ボタン
画面左上の見出しを右クリックすると画面中央付近に現在開かれているフォームの一覧が表示されます。選択してクリックするとそのフォームに移動します。
単にクリックすると目次画面に戻ります。
画面左上の見出しを右クリックすると画面中央付近に現在開かれているフォームの一覧が表示されます。選択してクリックするとそのフォームに移動します。
単にクリックすると目次画面に戻ります。
上図が「設定」「現在のデータベース」「ドキュメントタブを表示する」にチェック
下図が「ドキュメントタブを表示する」チェックを外したもの
【参考VBA】
Private Sub リボンナビ表示切替1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = acRightButton Then Exit Sub
If Shift = 0 Then
If IsNull(目次_Form) Then MsgBox "目次に戻れません。「終了」をクリックしてください。": Exit Sub
Dim varRet As Variant, Menu_Form As Variant
Menu_Form = 目次_Form
varRet = SysCmd(acSysCmdGetObjectState, acForm, Menu_Form)
If varRet = 0 Then DoCmd.OpenForm Menu_Form, acNormal, "", "", , acNormal
Forms(Menu_Form).Form.SetFocus
Exit Sub
End If
If 管理者権限F = False Or DM = False Or Shift = 0 Then Exit Sub
リボンナビ表示切替F = RibbonNavi(リボンナビ表示切替F)
End Sub
--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub リボンナビ表示切替1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
DoCmd.CancelEvent 'イベントをキャンセルしてショートカットメニューを表示させない
On Error GoTo Err_JOB
If Button = acRightButton Then DoCmd.RunCommand acCmdMoreWindows '右クリック時のみ処理を実行
Exit Sub
Err_JOB:
End Sub
登録した時のオートナンバーの値を求める
Dim TBL2 as Recordset
・
・
・
TBL2.Update
TBL2.Bookmark = TBL2.LastModified
登録ID = TBL2("登録ID").Value
オートナンバーのリセット
補足
オートナンバー型のフィールドは一度登録してしまうと次の番号から始まります。常に1から始まるようにするには以下のようにします。
Public Sub LocalWorkTable初期化()
WITH Forms![Prv_Frm]![Prv_Frm_SUBF02]
.Form.RecordSource = "LocalWorkTable_Dummy"
DoCmd.SetWarnings False
MySQL = "DELETE [LocalWorkTable].* FROM LocalWorkTable;"
DoCmd.RunSQL MySQL
DoCmd.SetWarnings True
If AutoNumberReset("LocalWorkTable", "登録ID") Then
.Form.RecordSource = ""LocalWorkTable""
Else
MsgBox "「LocalWorkTable」の初期化に失敗しました。": Exit Sub
End If
.Form.Requery
END With
End if
End sub
----------------------------------------------------------------------------------------------------------------------------------------------------------------------
' 標準モジュールで「AutoNumber_Rest」を作ります。
Option Compare Database
' オートナンバーリセット
Public Function AutoNumberReset(ByVal strTableName As String, ByVal strFieldName As String)
Dim db As Database
Dim strSQL As String
On Error GoTo Rest_Err
Set db = CurrentDb
strSQL = "ALTER TABLE " & strTableName & " ALTER COLUMN " & strFieldName & " COUNTER (1,1)"
db.Execute strSQL
AutoNumberReset = True
Exit Function
Rest_Err:
AutoNumberReset = False
MsgBox Error
End Function
データベースウィンドウの表示設定 F11キーの無効化、ショートカット キーを有効／無効、SHIFTキー／起動を出来なくする
補足事項：
フォームの不可視のDEBUGF変数をシステム設定テーブルから読込みます。「True」に設定するとツールの改修にはなにも制限がかかりません。
「False」にするとShiftキー+起動（autoexecや起動フォーム）の回避、F11キーによるデータベースウィンドウの表示やCTRL+GなどによるVBEの表示等一切できなくなります。
Public Sub MySetPropty1()
Dim Pro_perty As Property
On Error GoTo Err
If IsNull(DEBUGF) Then DEBUGF = False
'データベースウィンドウの表示設定
Set MDB1 = CurrentDb
MDB1.Properties("StartupShowDBWindow") = DEBUGF
Set MDB1 = Nothing
Exit Sub
Err:
'起動時の設定がまだ設定されていない場合、エラーが発生するのでプロパティを作成し設定します。
Set Pro_perty = MDB1.CreateProperty("StartupShowDBWindow", dbText, "False")
MDB1.Properties.Append Pro_perty
Set Pro_perty = Nothing
Set MDB1 = Nothing
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------------
Public Sub MySetPropty2()
Dim Pro_perty As Property
On Error GoTo Err
If IsNull(DEBUGF) Then DEBUGF = False
'ショートカット キーを有効／無効
Set MDB1 = CurrentDb
MDB1.Properties("AllowSpecialKeys") = DEBUGF
Set MDB1 = Nothing
Exit Sub
Err:
'起動時の設定がまだ設定されていない場合、エラーが発生するのでプロパティを作成し設定します。
Set Pro_perty = MDB1.CreateProperty("AllowSpecialKeys", dbText, "False")
MDB1.Properties.Append Pro_perty
Set Pro_perty = Nothing
Set MDB1 = Nothing
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------------
Public Sub MySetPropty3()
Dim prpty As Property
Dim varPropType
On Error GoTo Err
varPropType = dbBoolean
'SHIFTキー／起動を出来なくする
Set MDB1 = CurrentDb
MDB1.Properties("AllowBypassKey") = DEBUGF
Set MDB1 = Nothing
Exit Sub
Err:
'起動時の設定がまだ設定されていない場合、エラーが発生するのでプロパティを作成し設定します。
Set prpty = MDB1.CreateProperty("AllowBypassKey", varPropType, "False")
MDB1.Properties.Append prpty
Set prpty = Nothing
Set MDB1 = Nothing
End Sub
リストボックスの一行目を選択する
Private Sub Form_Load()
Me.lst_都道府県庁選択 = Me.lst_都道府県庁選択.ItemData(0)
End Sub
プルダウンメニューを表示させない
補足
データシートにおいて編集不可にしておいても、プルダウンメニューがあるものはどれが選択出来るのか通常では見えてしまいます。以下のVBAはFormatConditionsを使ってプルダウンメニュー
を表示させない方法です。
Public Sub 編集モード変更処理()
Dim MDB3 As Database, TBL3 As Recordset, TBL4 As Recordset
Dim JOKEN As String, i As LongPtr, K As LongPtr, Field_Name As String
Set MDB3 = CurrentDb
Set TBL4 = Forms!目次マスタ_FM]!目次マスタ_FM_SBF1].Form.RecordsetClone
For i = 0 To TBL4.Fields.Count - 1
Field_Name = TBL4.Fields(i).Name
If Field_Name = "保守F" Then GoTo 次の処理
If Field_Name = "連携F" Then GoTo 次の処理
With Forms!目次マスタ_FM]!目次マスタ_FM_SBF1].Form.Controls(Field_Name)
If 編集可否F_1 = False Then '編集モード
.FormatConditions.Item(0).Enabled = True
.Enabled = True
.Locked = False
End If
If 編集可否F_1 = True Then '一覧モード
.FormatConditions.Item(0).Enabled = False
.Enabled = False
.Locked = True
End If
End With
次の処理:
Next i
End Sub
フォームやコントールに変数を割り当てる
Set Frm1 = Forms![画面_FM]![画面_FM_SUBF03].Form
For II = 0 To 100
If II < RSTCnt Then
Frm1("fld" & II).ColumnHidden = False
Frm1("fld" & II).ControlSource = TBL1.Fields(II).Name
Frm1("ラベルfld" & II).Caption = TBL1.Fields(II).Name
Else
Frm1("fld" & II).ColumnHidden = True
End If
Next II
TBL1.Close
'各エリアの集計一覧
Dim KK As Long, Frm1 As Form, strFormName1 As String, strFormName2 As String
For KK = 1 To 5
strFormName1 = "画面_FM"
strFormName2 = "画面_FM_SUBF02" & KK
Set Frm1 = Forms(strFormName1)(strFormName2).Form
Frm1.Requery
Frm1.Form.RowHeight = 312 'データシートの高さ 15.6 1=20
For Each ctl In Frm1.Controls
If ctl.ControlType <> acLabel Then
ctl.ColumnWidth = 1050
End If
Next ctl
Next KK
コンボボックスにフォーカスした時に一覧データを設定する
Private Sub 表示区分名1_Enter()
MySQL = "SELECT [◆表示区分マスタ].表示区分名 FROM ◆表示区分マスタ ORDER BY [◆表示区分マスタ].表示順番;"
表示区分名1.RowSource = MySQL
表示区分名1.Requery
End Sub
----------------------------------------------------------------------------------------------------------------------------------------------
Private Sub 表示区分名1_Exit(Cancel As Integer)
表示区分名1.RowSource = ""
表示区分名1.Requery
End Sub
コンボボックスを使うときにはじめてデータを読み込む
Private Sub 表示区分名1_Enter()
MySQL = "SELECT [◆表示区分マスタ].表示区分名 FROM ◆表示区分マスタ ORDER BY [◆表示区分マスタ].表示順番;"
表示区分名1.RowSource = MySQL
表示区分名1.Requery
End Sub
----------------------------------------------------------------------------------------------------------------------------------------------
Private Sub 表示区分名1_Exit(Cancel As Integer)
表示区分名1.RowSource = ""
表示区分名1.Requery
End Sub
サブデータシートの展開と折り畳み
Private Sub 全て展開_Click()
If 一覧表区分 = 3 Then 全て展開する
End Sub
Public Sub 全て展開する()
If Forms![Frm_FM]![Frm_FM_SUBF01].Form.Recordset.RecordCount = 0 Then Exit Sub
Forms![Frm_FM]![Frm_FM_SUBF01].SetFocus
Forms![Frm_FM]![Frm_FM_SUBF01]![年度].SetFocus
'すべて展開コマンドを実行
DoCmd.RunCommand acCmdSubdatasheetExpandAll
End Sub
'-----------------------------------------------------------------
Private Sub 全て畳む_Click()
If 一覧表区分 = 3 Then 全て折り畳む
End Sub
Public Sub 全て折り畳む()
If Forms![Frm_FM]![Frm_FM_SUBF01].Form.Recordset.RecordCount = 0 Then Exit Sub
Forms![Frm_FM]![Frm_FM_SUBF01].SetFocus
Forms![Frm_FM]![Frm_FM_SUBF01]![年度].SetFocus
'すべて折りたたみコマンドを実行
DoCmd.RunCommand acCmdSubdatasheetCollapseAll
End Sub
クエリーをVBAで開く
補足：
下記のクエリー名は一例です。アクションクエリーで警告を出さないように、「DoCmd.SetWarnings False」とし「DoCmd.SetWarnings True」で元に戻します。
アクションクエリーを実行中にエラーになると「DoCmd.SetWarnings False」となりデバック中に意図せずフォーム等が保存されたりされなかったりします。変更時の保存の警告が出ない為です。
DoCmd.SetWarnings False
DoCmd.CopyObject , "クライアントPC情報起動日WORK", acTable, "クライアントPC情報起動日WORK_Empty"
DoCmd.OpenQuery "Z000_クライアントPC情報起動日_追加qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z001_クライアントPC情報WORK削除F_更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z002_クライアントPC情報削除F_Rest更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z003_クライアントPC情報削除F_更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z000_クライアントPC情報_削除qey", acViewNormal, acEdit
DoCmd.SetWarnings True
クリックしたレコードに戻る
'クリックしたレコードに戻る
Me.Requery
DoCmd.GoToRecord , , acLast
DoCmd.GoToRecord , , acGoTo, Me.Form.CurrentRecord
クリップボードにコピーする
[備考].SetFocus
[備考].SelStart = 0
[備考].SelLength = Len([備考])
DoCmd.RunCommand acCmdCopy
クロス集計クエリーのフォーム
補足：
クロス集計は集計結果の横軸が不確定なので、予め100個枠のみ用意しておき、それに名前とデータを入れ込みます。
Forms![フォーム_FM]![フォーム_FM_SUBF03].Form.RecordSource = "クロス集計1qey"
Dim RstCnt As Integer, II As Integer
Dim ctl As Control
Set TBL3 = MDB1.OpenRecordset("クロス集計1qey", dbOpenDynaset, dbSeeChanges)
TBL3.MoveLast
RstCnt = TBL3.Fields.Count
If RstCnt > 100 Then MsgBox "年月が100以上あります。101個目から表示出来ません。'100個あれば増やせばよい
For II = 0 To 100
Set ctl = Forms![フォーム_FM]![フォーム_FM_SUBF03]("fld" & II)
If II < RstCnt Then
ctl.ColumnHidden = False
Forms![フォーム_FM]![フォーム_FM_SUBF03]("fld" & II).ControlSource = TBL3.Fields(II).Name
Forms![フォーム_FM]![フォーム_FM_SUBF03]("ラベルfld" & II).Caption = TBL3.Fields(II).Name
Else
ctl.ColumnHidden = True
End If
Next II
TBL3.Close
クエリーで連番
クエリーで書きます。
表示順番: DCount("*","Tableオブジェクト_表示qey","Name<=" & "'" & [NAME] & "'")
その他のウインドウ表示
DoCmd.CancelEvent 'イベントをキャンセルしてショートカットメニューを表示させない
If Button = acRightButton Then DoCmd.RunCommand acCmdMoreWindows '右クリック時のみ処理を実行
acCmdMoreWindows
データシート選択表示
Dim ctl As Control
For Each ctl In Forms![情報_FM]![情報_FM_SUBF01].Controls
If ctl.ControlType <> acLabel Then
If ctl.Name = "処理状況" Then GoTo 次の処理
If ctl.Name = "基本情報_管理番号" Then GoTo 次の処理
If ctl.Name = "非表示F" Then GoTo 次の処理
If ctl.Name = "取得日時" Then GoTo 次の処理
If ctl.Name = "取得者" Then GoTo 次の処理
If ctl.Name = "登録日" Then GoTo 次の処理
If ctl.Name = "登録時間" Then GoTo 次の処理
If ctl.Name = "登録者" Then GoTo 次の処理
If ctl.Name = "登録ID" Then GoTo 次の処理
If ctl.Name = "実施年度" Then GoTo 次の処理
If InStr(ctl.Name, 情報区分) > 0 Then GoTo 次の処理
ctl.ColumnHidden = True
End If
次の処理:
Next ctl
テーブルのフィールド名を取得
Private Sub コマンド0_Click()
Dim db As Database
Dim rs As Recordset
Dim i As Long
Set db = CurrentDb()
Set rs = db.OpenRecordset("T-顧客マスター", dbOpenTable)
Me!テキスト1 = Null
For i = 0 To rs.Fields.Count - 1
Me!テキスト1 = Me!テキスト1 & rs.Fields(i).Name & vbCrLf
Next
Set rs = Nothing
Set db = Nothing
End Sub
テーブルの存在判定をして削除
'ACCESS VBA テーブルの存在判定をして削除
2011-06-16 11:46:22
テーマ：ACCESS VBA
If DCount("*", "MSysObjects", "[Name]='テーブル1'") > 0 Then
DoCmd.DeleteObject acTable, "テーブル1"
End If
テーブルの要素をフォームのフィールドに割り当てる
'テーブルの要素をフォームのフィールドに割り当てる
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset(テーブル名, dbOpenDynaset, dbSeeChanges)
RstCnt = TBL1.Fields.Count
For II = 0 To 100
If II < RstCnt Then
Frm1("fld" & II).ColumnHidden = False
Frm1("fld" & II).TextAlign = 1 '.TextAlign 左配置:1 中央配置:2 右配置:3 均等割り付け:4
If TBL1.Fields(II).Type = dbLong Then Frm1("fld" & II).TextAlign = 3
If TBL1.Fields(II).Type = dbSingle Then Frm1("fld" & II).TextAlign = 3
If InStr(TBL1.Fields(II).Name, "登録") > 0 And InStr(TBL1.Fields(II).Name, "ID") = 0 Then Frm1("fld" & II).TextAlign = 2
Frm1("fld" & II).ControlSource = TBL1.Fields(II).Name
Frm1("ラベルfld" & II).Caption = TBL1.Fields(II).Name
Else
Frm1("fld" & II).ColumnHidden = True
End If
Next II
テキスト_カンマ単位_ADODB_Streem
With CreateObject("ADODB.Stream")
If Forms![Z101_技術資料_FM]![文字CODE区分] = 1 Then .Charset = "_autodetect_all"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 2 Then .Charset = "SJIS"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 3 Then .Charset = "UTF-8"
.Open
.LoadFromFile Target
Do Until .EOS
buf = .ReadText(-2)
i = i + 1
tmp = Split(buf, ",")
For j = 0 To UBound(tmp)
Forms![Z101_技術資料_FM]![技術資料内容] = Forms![Z101_技術資料_FM]![技術資料内容] & tmp(j) & vbCrLf
Debug.Print Forms![Z101_技術資料_FM]![技術資料内容]
Next j
Loop
.Close
End With
テキスト一気読込_ADODB_Streem
With CreateObject("ADODB.Stream")
If Forms![Z101_技術資料_FM]![文字CODE区分] = 1 Then .Charset = "_autodetect_all"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 2 Then .Charset = "SJIS"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 3 Then .Charset = "UTF-8"
.Open
.LoadFromFile Target
Do Until .EOS
buf1 = .ReadText(-2) '一行ずつ読込みは-2、一気読込みは-1、省略の場合は-1となります。
buf1 = Replace(buf1, vbLf, "")
buf1 = Replace(buf1, vbCrLf, "")
RecCnt = RecCnt + 1
Loop
.Close
End With
テキスト書込み_ADODB.STREAM
参考URL:http://officetanaka.net/excel/vba/file/file11.htm
Sub Sample1()
Dim Target As String
Target = "D:\Work\Sample.txt"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText "名前1", 1
.SaveToFile Target, 2
.Close
End With
End Sub
------------------------------------------------------------
第2引数を省略するか「0」を指定すると、末尾に改行コードを書き込みません。
Sub Sample1()
Dim Target As String
Target = "D:\Work\Sample.txt"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText "名前1", 0
.WriteText "名前2"
.WriteText "名前3"
.SaveToFile Target, 2
.Close
End With
End Sub
------------------------------------------------------------
WriteTextメソッドが、書き込む命令です。第2引数に「1」を指定すると、書き込むデータ(上では"名前1")の後ろに改行コードを書き込みます。
Sub Sample1()
Dim Target As String
Target = "D:\Work\Sample.txt"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText "名前1", 1
.WriteText "名前2", 1
.WriteText "名前3", 1
.SaveToFile Target, 2
.Close
End With
End Sub
-------------------------------------------------------------
SaveToFileメソッドが、ファイルに保存する命令です。第1引数には、保存したいファイルの名前を指定します。第2引数は、ちょっとややこしいです。
値 指定したファイルが存在する場合 指定したファイルが存在しない場合
1 実行時エラーになる 作成して書き込む
2 上書きする 作成して書き込む
テキストボックスの名前を変数で使う
For i = 1 to 5
example = Me.Controls("txtbox" & i)
Next i
テキストボックス内でマウススクロールする
Option Compare Database
Option Explicit
' Windows が起動してからの経過ミリ秒数を取得
Private Declare PtrSafe Function GetTickCount Lib "Kernel32" () As Long
' テキストボックス用
Private Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare PtrSafe Function apiGetFocus Lib "user32" _
Alias "GetFocus" () As Long
Private Const WM_VSCROLL As Long = &H115& ' 垂直スクロール
Private Const SB_LINEUP As Long = &H0& ' 上方向
Private Const SB_LINEDOWN As Long = &H1& ' 下方向
Private mLastWheeled As Long ' 前回のホイール使用時刻(GetTickCount)
Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
On Error GoTo erh
mLastWheeled = GetTickCount
If Not Me.ActiveControl Is Me.[技術資料内容] Then Exit Sub
Dim i As Integer
Dim hWnd As Long: hWnd = fhWnd(Me.ActiveControl)
For i = 1 To Abs(Count)
SendMessage hWnd, WM_VSCROLL, IIf(Count < 0, SB_LINEUP, SB_LINEDOWN), 0&
Next
erh:
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
Cancel = (GetTickCount - mLastWheeled) < 100 ' ホイール使用後0.1秒未満レコード移動不可
End Sub
Private Function fhWnd(ctl As Control) As Long
On Error Resume Next
ctl.SetFocus
If Err Then
fhWnd = 0
Else
fhWnd = apiGetFocus
End If
On Error GoTo 0
End Function
'*********** Code End *************
テキスト読込_ADODB_Streem
With CreateObject("ADODB.Stream")
.Charset = "SJIS" '"UTF-8" "_autodetect_all"
.Open
.LoadFromFile Path_File
Do Until .EOS
buf1 = .ReadText(-2)
buf1 = Replace(buf1, vbLf, "")
buf1 = Replace(buf1, vbCrLf, "")
RecCnt = RecCnt + 1
Loop
.Close
End With
テキスト読込ADODB_Stream 2
'http://officetanaka.net/excel/vba/file/file10.htm
Sub Sample3()
Dim buf As String, Target As String, i As Long
Dim tmp As Variant, j As Long
Target = "D:\Work\UTF-8のテキスト.csv"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile Target
Do Until .EOS
buf = .ReadText(-2)
i = i + 1
tmp = Split(buf, ",")
For j = 0 To UBound(tmp)
Cells(i, j + 1) = tmp(j)
Next j
Loop
.Close
End With
End Sub
テキスト連続読込ADODB_Stream
With CreateObject("ADODB.Stream")
.Charset = "SJIS"
.Open
.LoadFromFile Path_File
Do Until .EOS
buf1 = .ReadText(-2)
buf1 = Replace(buf1, vbLf, "")
buf1 = Replace(buf1, vbCrLf, "")
buf1 = Replace(buf1, "|", "_")
buf1 = Replace(buf1, "`", "'")
buf2 = Replace(buf1, Chr(34) & "," & Chr(34), "`") '「","」文字を「`」に一時変更する
buf2 = Replace(buf2, ",", "|") 'ダブルクォーテーションに囲まれた「,」を「|」に一時変更する
buf2 = Replace(buf2, "`", Chr(34) & "," & Chr(34)) '「`」→「","」
buf2 = Replace(buf2, Chr(34) & "|", Chr(34) & ",") '「|」→「,」
buf2 = Replace(buf2, vbLf, "")
buf2 = Replace(buf2, vbCrLf, "")
'テーブルに書き込む
Loop
.Close
End With
パラメータークエリについて
'パラメータークエリについて
Parameters("sql分に含まれるフォーム!コントロール名")=実際の値に相当するフォーム!コントロール名（入っている値）
If 移動区分 = 1 Then
'MySQL = "SELECT リスト情報.契約エリア名, リスト情報.締年月 FROM リスト情報;"
MySQL = "SELECT リスト情報.発注番号 From リスト情報 WHERE (((" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_契約エリア名]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_契約エリア名] = [契約エリア名], 1, 0))) = 1) And ((" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_締年月]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_締年月] = [締年月], 1, 0))) = 1));"
End If
If 移動区分 = 2 Then
'MySQL = "SELECT リスト情報_過去.契約エリア名, リスト情報_過去.締年月 FROM リスト情報_過去;"
MySQL = "SELECT リスト情報_過去.発注番号 FROM リスト情報_過去 WHERE (((" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_契約エリア名]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_契約エリア名] = [契約エリア名], 1, 0))) = 1) And ((" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_締年月]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_締年月] = [締年月], 1, 0))) = 1));"
End If
Set MDB1 = CurrentDb
Set MyQry = MDB1.CreateQueryDef("", MySQL)
With MyQry
.Parameters("[Forms]![U017_データ情報_現過_FM]![対象_契約エリア名]") = [Forms]![U017_データ情報_現過_FM]![対象_契約エリア名]
.Parameters("[Forms]![U017_データ情報_現過_FM]![対象_締年月]") = [Forms]![U017_データ情報_現過_FM]![対象_締年月]
End With
ひな型の一部領域に罫線、フォント、文字位置を設定する
'表全体の形式
For G_Sht = 1 To STCount
With MyXLS
'罫線を描画 '表全体を選択
.Sheets(G_Sht).Select
.Range("B7").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.Borders.LineStyle = xlContinuous '格子柄
.Selection.HorizontalAlignment = xlCenter '[横位置]
'表全体の形式
.Selection.Font.Name = "Meiryo UI" 'フォント
.Selection.Font.Size = 10 'フォントサイズ
.Selection.RowHeight = 18 '行の高さ
.Selection.VerticalAlignment = xlCenter '上下中央揃え
.Selection.HorizontalAlignment = xlRight '[右位置]
' .Selection.EntireColumn.AutoFit
.Range("B7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlCenter
.Range("C7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlLeft
.Range("D7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlCenter
If .Range("E6").Value = "個別" Then
.Range("E7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlCenter
End If
End With
Next G_Sht
コマンドボタン形状
'コマンドボタン形状の設定
ファイル参照.Shape = TBL2![コマンドボタン形状]
フィルター解除.Shape = TBL2![コマンドボタン形状]
目次更新.Shape = TBL2![コマンドボタン形状]
編集可否.Shape = TBL2![コマンドボタン形状]
リボンナビ表示1.Shape = TBL2![コマンドボタン形状]
終了.Shape = TBL2![コマンドボタン形状]
ファイルの存在チェックとファイルを開く
Private Sub ファイルを開く_Click()
'ファイルの存在チェック
If IsNull(データリストEXCEL_FILE) Then MsgBox "エクセルファイルが選択されていません。": Exit Sub
If ExistFile(データリストEXCEL_FILE) = False Then MsgBox "エクセルファイルが存在しません。": Exit Sub
CreateObject("Shell.Application").ShellExecute データリストEXCEL_FILE
End Sub
'標準プロシージャに以下を作成 名前：Exist_File
Option Compare Database
'ファイルの存在を確認する existとは「存在する」と言う意味
Public Function ExistFile(strFileName As String) As Boolean
ExistFile = (Len(Dir(strFileName, vbHidden)) > 0)
End Function
.ColumnWidth
例１：「商品名」の列幅を10論理cmに設定する
Private Sub cmd実行_Click()
Me!frm売上明細_sub!商品名.ColumnWidth = 10 * 567
End Sub
◇システム設定_◇利用者マスタ
◇システム設定呼出し 'システム設定の呼び出し
◆利用者名呼出し '利用者名の検索・表示
Public Sub ◇システム設定呼出し()
Set MDB1 = CurrentDb
Set TBL2 = MDB1.OpenRecordset("◇システム設定", dbOpenDynaset, dbSeeChanges)
TBL2.FindFirst "拡張機能システムのタイトル名 = " & "'" & Left(CurrentProject.Name, InStr(1, CurrentProject.Name, "_ver", vbBinaryCompare) - 1) & "'"
If TBL2.NoMatch Then
目次_Form =""
DM =false
BTN番号 = 0
""
Else
目次_Form = TBL2![目次_FormName]
DM = TBL2![DM]
BTN番号 = Nz(TBL2![コマンドボタン形状], "")
If InStr("01234567", BTN番号) = 0 Then BTN番号 = 0
'タイトルの色
If TBL2![見出色F] = True Then
Dim Gradno As Long
If Nz(TBL2![gSTILE],"") = "" Then Gradno = リボンナビ表示切替1.Gradient
If Nz(TBL2![gSTILE],"") <> "" And Nz(TBL2![gSTILE]) <= 26 Then Gradno = TBL2![gSTILE]
If Nz(TBL2![見出し前景色],"") <> "" Then リボンナビ表示切替1.ForeColor = TBL2![見出し前景色]
If Nz(TBL2![見出し背景色],"") <> "" Then リボンナビ表示切替1.BackColor = TBL2![見出し背景色]
リボンナビ表示切替1.Gradient = Gradno
End If
End If
TBL2.Close
Set MDB1 = Nothing
Set TBL2 = Nothing
'コマンドボタン形状
リンクテーブル読込み.Shape = BTN番号
フィルター解除.Shape = BTN番号
実施F_切替.Shape = BTN番号
実施Fリセット.Shape = BTN番号
リンク名変更実行.Shape = BTN番号
終了.Shape = BTN番号
リンクテーブルマネージャー.Shape = BTN番号
End Sub
Public Sub ◆利用者名呼出し()
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset("◆利用者マスタ", dbOpenDynaset, dbSeeChanges)
TBL1.MoveLast
TBL1.FindFirst "ログインユーザー名=" & "'" & NetUserName() & "'"
If TBL1.NoMatch Then
利用者名 = NetUserName()
表示区分名 = "Non"
管理者権限F = False
Else
利用者名 = TBL1![利用者名]
表示区分名 = TBL1![表示区分名]
管理者権限F = TBL1![管理者権限F]
End If
TBL1.Close
Set MDB1 = Nothing
Set TBL1 = Nothing
End Sub
２つのテーブルに共通するレコードを削除したい
１、テーブル内容
Aテーブル フィールド：ID番号、・・
Bテーブル フィールド：削除番号、・・
２、まず、選択クエリで削除したいIDのサブクエリを作る。
・AテーブルとBテーブルのIDを結合。
・表示のSQLでサブクエリをゲット
内容は
SELECT Aテーブル.ID番号
FROM Aテーブル INNER JOIN Bテーブル
ON Aテーブル.ID番号 = Bテーブル.削除ID;
３、次に削除クエリを作成
・新規クエリで削除クエリを作成
・Aテーブルのみ選択
・ID番号を下にドラッグ
・その抽出条件に２で作成したサブクエリを「;」を外して
IN ( )をつけて入力
内容は
IN (SELECT Aテーブル.ID番号
FROM Aテーブル INNER JOIN Bテーブル
ON Aテーブル.ID番号 = Bテーブル.削除ID)
これで、クエリを実行することにより、Aテーブルの内容が、
Bテーブルの削除番号と同じID番号のレコードを削除できます。
Access Runtime環境で動作しているかを判定する
Public Function リボンナビの表示()
'Runtimeが実行されているかSysCmdメソッドで判定
If SysCmd(acSysCmdRuntime) Then
'Runtimeで実行された場合の処理はなにもしない
Else
DoCmd.ShowToolbar "Ribbon", acToolbarYes 'リボンの表示
DoCmd.SelectObject acForm, "", True 'ナビゲーションウィンドウの表示
End If
End Function
Public Function リボンナビの非表示()
'Runtimeが実行されているかSysCmdメソッドで判定
If SysCmd(acSysCmdRuntime) Then
'Runtimeで実行された場合の処理はなにもしない
Else
DoCmd.ShowToolbar "Ribbon", acToolbarNo 'リボンの非表示
DoCmd.SelectObject acForm, "", True 'ナビゲーションウィンドウの非表示
DoCmd.RunCommand acCmdWindowHide
End If
End Function
If SysCmd(acSysCmdRuntime) = False Then リボンナビ表示1.Visible = True 'Runtimeが実行されているかSysCmdメソッドで判定
ACCESS_EXCEL操作1
'エクセルファイルの作成・開く=1================================================
Dim AppObj As Object 'Excel.Applicationオブジェクトの宣言
Dim WBObj As Object 'Excel.Workbookオブジェクトの宣言
Dim WsObj As Object 'Excel.WorkSheetオブジェクトの宣言
Dim FilePath As String
FilePath = "D:\test.xlsx" 'Excelファイルのパスを指定
'FilePath = Application.CurrentProject.Path & "\Sample.xlsx" 'Excelファイルのパスを指定
'※ Excelファイルが使用するAccessファイルと同じフォルダにある場合の表記
Set AppObj = CreateObject("Excel.Application") '実行時バインディング
Set WBObj = AppObj.Workbooks.Open(FilePath) 'ワークブックを開く
Set WsObj = WBObj.Worksheets("Sheet1")
AppObj.Visible = True 'Excelアプリケーションを表示する
'ワークシートへの処理
WsObj.Range("A1").Value = "Access"
'ワークシートのコピー作成
WsObj.Copy after:=WsObj
WBObj.ActiveSheet.Name = "test"
'Excelを保存して閉じる
WBObj.Save 'ワークブックを保存する
WBObj.Close 'ワークブックを閉じる
AppObj.Quit
Exit Sub
ACCESS_EXCEL操作2
'エクセルファイルの作成・開く=1================================================
Dim MyXLS As Object 'Excel.Applicationオブジェクトの宣言
Dim MyBook As Object 'Excel.Workbookオブジェクトの宣言
Dim Myseets As Object 'Excel.WorkSheetオブジェクトの宣言
Dim FilePath As String
FilePath = "D:\test.xlsx" 'Excelファイルのパスを指定
'FilePath = Application.CurrentProject.Path & "\Sample.xlsx" 'Excelファイルのパスを指定
'※ Excelファイルが使用するAccessファイルと同じフォルダにある場合の表記
Set MyXLS = CreateObject("Excel.Application") '実行時バインディング
Set MyBook = MyXLS.Workbooks.Open(FilePath) 'ワークブックを開く
Set Myseets = MyBook.Worksheets("Sheet1")
If Dir(FilePath) = "" Then
'新規
Set MyBook = MyXLS.Workbooks.Add
Else
'更新
End If
MyXLS.Visible = False 'Excelアプリケーションを表示する
'ワークシートへの処理
Myseets.Range("A1").Value = "Access"
'ワークシートのコピー作成
Myseets.Copy after:=Myseets
MyBook.ActiveSheet.Name = "test2"
'Excelを保存して閉じる
MyBook.Save 'ワークブックを保存する
MyBook.Close 'ワークブックを閉じる
MyXLS.Quit
Exit Sub
'エクセルファイルの作成・開く=2================================================
'Dim MyXLS As Object 'Excel.Applicationオブジェクトの宣言
'Dim MyBook As Excel.Workbook
'Dim Myseets As Excel.Worksheet
Set MyXLS = CreateObject("Excel.Application")
With MyXLS
.Visible = False
.UserControl = True
.Workbooks.Open FileName:="D:\test.xlsx"
.Sheets(1).Select
.Range(MyXLS.Selection, MyXLS.Selection.End(xlUp)).Select 'CTRL+↑キー
.Range(MyXLS.Selection, MyXLS.Selection.End(xlToLeft)).Select 'CTRL+←キー
.Range(MyXLS.Selection, MyXLS.Selection.End(xlToRight)).Select 'CTRL+SHIFT+→key
.Range(MyXLS.Selection, MyXLS.Selection.End(xlDown)).Select 'CTRL+SHIFT+↓key
.Selection.Borders.LineStyle = xlContinuous '格子柄
' .Selection.Borders.Weight = xlHairline '極細線
.Selection.Borders.Weight = xlThin '細線
' .Selection.BorderAround Weight:=xlMedium '外枠
.Range("A1").Select
.Range(MyXLS.Selection, MyXLS.Selection.End(xlToRight)).Select
.Selection.Interior.ColorIndex = 36 ' 10092543 '薄い黄色 RGB(R,G,B)でもよい
.Selection.RowHeight = 20 '行の高さ
.Selection.VerticalAlignment = xlCenter '上下中央揃え
.DisplayAlerts = False
.ActiveWorkbook.Save
.ActiveWindow.Close
.Quit
End With
Set MyXLS = Nothing
MsgBox ("終了")
Exit Sub
ACCESS_EXCEL操作3
AccessからExcelを操作する手順
まず、CreateObject(“Excel.Application”)を用いて、Excelをオブジェクト型変数に格納しVBAで操作できるようにします。
その後はExcelVBAで使用するコードをほぼそのまま使用することができます。
プロパティを指定する際、Excelを格納した変数を頭に記入しないとExcelVBAの操作であることが認識されないので注意が必要です。
つい忘れがちになるので、Excelの操作ステップが多いならWithステートメントを使用してコードを省略した方がわかりやすくなります。
①Excelファイルの新規作成と保存
Sub AccessVBAでExcelファイルの新規作成と保存()
Dim 保存場所ホルダ & "\" & 保存ファイル名 As Object
Set MyXLS = CreateObject(“Excel.Application”)
MyXLS.Visible = True
Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject(“Wscript.Shell”)
DesktopPath = WSH.SpecialFolders(“Desktop”)
FilePath = DesktopPath & “\作成したExcelファイル.xlsx”
MyXLS.Workbooks.Add
With MyXLS.Workbooks(MyXLS.Workbooks.Count)
.Sheets(1).Cells(1, 1) = “aaaaa”
.SaveAs FileName:=FilePath
.Close
End With
MyXLS.Quit
Set MyXLS = Nothing
Set WSH = Nothing
End Sub
②既存Excelファイルの起動と上書き保存
Sub Accessで既存のExcelファイル起動と編集()
Dim MyXLS As Object
Set MyXLS = CreateObject(“Excel.Application”)
MyXLS.Visible = True
Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject(“Wscript.Shell”)
DesktopPath = WSH.SpecialFolders(“Desktop”)
FilePath = DesktopPath & “\元Excelファイル.xlsx”
MyXLS.Workbooks.Open FileName:=FilePath
With MyXLS.Workbooks(MyXLS.Workbooks.Count)
.Sheets(1).Cells(1, 1) = “aaaaa”
.Save
.Close
End With
MyXLS.Quit
Set MyXLS = Nothing
Set WSH = Nothing
End Sub
ACCESS_FP200パイパーリンク
[FP2000] ハイパーリンクが設定されている Access データベースの表示方法
対象製品
この記事は、以前は次の ID で公開されていました: JP237805
概要
この資料は、ハイパーリンクが設定されている Microsoft Access 2000 のデータベースの結果を表示する方法について説明したものです。
詳細
ハイパーリンクが設定されている Microsoft Access 2000 のデータベースの結果を表示するような ASP (Active Server Page) ファイルを FrontPage 2000 で作成し、ブラウザで表示した際に、ハイパーリンクはテキストもしくは以下の例のように表示されます。
"#http://www.microsoft.com/#"
解決方法
この問題に対処するには、以下の手順を参照してください。
(1)
ドラッグ アンド ドロップで、Access 2000 のデータベースを FrontPage 2000 にインポートします。
(2)
[データベース接続の追加] ダイアログ ボックスに接続の名前を入力し、[はい] をクリックします。
(3)
以下のメッセージが表示されましたら [はい] をクリックします。
"fpdb" フォルダにデータベース ファイルを保存することをお奨めします。データベース ファイルをこのフォルダにインポートしますか?"
(4)
[挿入] メニューの [データベース] をポイントし、[結果] をクリックします。
(5)
[データベース結果ウィザード] を実行し、データベースに対する適切な設定を行い、[完了] をクリックします。
(6)
データベース結果領域を含む ASP ファイルで、リンクを含むフィールドを選択します。
(7)
フィールドを右クリックし、表示されているショートカット メニューから [ハイパーリンク] をクリックします。
(8)
[ハイパーリンクの作成] ダイアログ ボックスで、URL ボックスにある " http:// "を削除します。
(9)
[パラメータ] をクリックします。
(10)
[ハイパーリンクのパラメータ] ダイアログ ボックスで、[フィールド値の挿入] をクリックし、ハイパーリンクを含むデータベース フィールド名を選択します。
(11)
[OK] をクリックします。
(12)
ハイパーリンクの作成] ダイアログ ボックスで、[OK] をクリックします。
(13)
[ファイル] メニューの [上書き保存] をクリックします。
関連情報
この資料は米国 Microsoft Corporation から提供されている Knowledge Base の Article ID 237805 (最終更新日 2000-09-11) をもとに作成したものです。
URL:http://support.microsoft.com/default.aspx?scid=kb;ja;237805
ACCESS_タイトルを入れる
Public Sub AppTitle_Setting()
Dim MDB0 As Database, prp As Property
Set MDB0 = CurrentDb
On Error GoTo Err_SetAppTitle
MDB0.Properties("AppTitle") = Replace(CurrentProject.Name, ".accdb", "")
Application.RefreshTitleBar
Exit_SetAppTitle:
Set MDB0 = Nothing
Exit Sub
Err_SetAppTitle:
If Err.Number = 3270 Then
'"AppTitle"プロパティが見つからないときはそのプロパティを作成する
'(これは起動時の設定がされていないときに発生します)
Set prp = MDB0.CreateProperty("AppTitle", dbText, Replace(CurrentProject.Name, ".accdb", ""))
MDB0.Properties.Append prp
Resume Next
End If
Resume Exit_SetAppTitle:
End Sub
Accessをランタイムモードで起動させる方法
Accessの本体である「MSACCESS.EXE」を起動する際、コマンドラインに”スイッチ”と呼ばれるオプションを追記して実行すると、Accessをある特定の状態で起動させることができます。
それらのスイッチのうち、「/runtime」というオプションを使うと、Accessをラインタイムモードで起動させることができます。
たとえば、「ファイル名を指定して実行」ダイアログ、あるいは特定のAccessデータベースファイルを起動するようなショートカットキーのリンク先において、次のような指定を行います。
MSACCESS.EXE /runtime "C:\Users\......nts\Database1.accdb"
この場合、Accessが起動するとともに、データベースファイル”Database1.accdb”がランタイムモードの状態で開かれます。
acSysCmdInitMeter_プログレスバー
SysCmd acSysCmdInitMeter, "マスタ取得 [" & 入力_シート名 & "] Reading Data...", Max_Row 'プログレスバー表示開始
SysCmd acSysCmdUpdateMeter, KK 'プログレスバー表示更新
SysCmd acSysCmdRemoveMeter 'プログレスバー表示終了
AttachDSNLess_Table
Option Compare Database
'参考URL:https://docs.microsoft.com/ja-jp/office/troubleshoot/access/create-dsn-less-connection-linkted-table
'//Name : AttachDSNLessTable
'//Purpose : Create a linked table to SQL Server without using a DSN
'//Parameters
'// stLocalTableName: Name of the table that you are creating in the current database
'// stRemoteTableName: Name of the table that you are linking to on the SQL Server database
'// stServer: Name of the SQL Server that you are linking to
'// stDatabase: Name of the SQL Server database that you are linking to
'// stUsername: Name of the SQL Server user who can connect to SQL Server, leave blank to use a Trusted Connection
'// stPassword: SQL Server user password
Function AttachDSNLessTable(stLocalTableName As String, stRemoteTableName As String, stServer As String, stDatabase As String, Optional stUsername As String, Optional stPassword As String)
On Error GoTo AttachDSNLessTable_Err
Dim td As TableDef
Dim stConnect As String, ODBC_Driver As String
'変数を代入
LinkConnection = "ODBC;DRIVER=" & ODBCドライバ名 & ";SERVER=" & SQLサーバー名 & ";UID=" & ユーザーID & ";PWD=" & パスワード & ";APP=Microsoft Office" & ";DATABASE=" & 接続先データベース名
stServer = SQLサーバー名
stDatabase = 接続先データベース名
stPassword = パスワード
stUsername = ユーザーID
ODBC_Driver = ODBCドライバ名
For Each td In CurrentDb.TableDefs
If td.Name = stLocalTableName Then
CurrentDb.TableDefs.Delete stLocalTableName
End If
Next
If Len(stUsername) = 0 Then
'//Use trusted authentication if stUsername is not supplied.
stConnect = "ODBC;DRIVER=" & ODBCドライバ名 & ";SERVER=" & stServer & ";DATABASE=" & stDatabase & ";Trusted_Connection=Yes"
Else
'//WARNING: This will save the username and the password with the linked table information.
stConnect = "ODBC;DRIVER=" & ODBCドライバ名 & ";SERVER=" & stServer & ";DATABASE=" & stDatabase & ";UID=" & stUsername & ";PWD=" & stPassword
End If
Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, stConnect)
CurrentDb.TableDefs.Append td
AttachDSNLessTable = True
Exit Function
AttachDSNLessTable_Err:
AttachDSNLessTable = False
MsgBox "AttachDSNLessTable encountered an unexpected error: " & Err.Description
End Function
AutoNumberReset
Public Sub ●U013_管理簿VO情報WORK初期化()
WITH Forms![U013_完成報告その他管理_FM]![U013_完成報告その他管理_FM_SUBF02]
.Form.RecordSource = "●U013_DUMMY_WORK"
DoCmd.SetWarnings False
MySQL = "DELETE [●U013_管理簿VO情報WORK].* FROM ●U013_管理簿VO情報WORK;"
DoCmd.RunSQL MySQL
DoCmd.SetWarnings True
If AutoNumberReset("●U013_管理簿VO情報WORK", "登録ID") Then
.Form.RecordSource = "U013_●U013_管理簿VO情報WORK_表示qey"
Else
MsgBox "「●U013_管理簿VO情報WORK」の初期化に失敗しました。": Exit Sub
End If
.Form.Requery
END With
End if
CheckLinkTable
Option Compare Database
Option Explicit
Const TABLE_NAME As String = "利用者マスタ"
Public Function CheckLinkTable()
Dim rs As Recordset
On Error GoTo eh
Set rs = Currenttdb.OpenRecordset(TABLE_NAME)
CheckLinkTable = True
Exit Function
eh:
CheckLinkTable = False
End Function
CreateQueryDef
MySQL = "SELECT DISTINCT 顧客情報.登録年月 FROM 顧客情報 ORDER BY 顧客情報.登録年月;"
Set MDB1 = CurrentDb
Set MyQry = MDB1.CreateQueryDef("", MySQL)
Dim RecCnt As Long
Set TBL1 = MyQry.OpenRecordset(dbOpenDynaset, dbSeeChanges)
If TBL1.BOF And TBL1.EOF Then
TBL1.Close
Set TBL1 = Nothing
Set MDB1 = Nothing
Exit Sub
End If
CreateQueryDef2
Dim MyQry As QueryDef, MySQL As String
MySQL = "SELECT DISTINCT [◆テーブル_見出しマスタ].見出し名, [◆テーブル_見出しマスタ].FM記号 " & _
"From ◆テーブル_見出しマスタ " & _
"WHERE ((([◆テーブル_見出しマスタ].見出し名) Like '" & "*羽賀*" & "' Or ([◆テーブル_見出しマスタ].見出し名) Like '共用*') AND " & _
"(([◆テーブル_見出しマスタ].[テーブル名])= '" & テーブル名 & " ') AND (([◆テーブル_見出しマスタ].FM記号) = '" & Form_Name & "'));"
Set MDB1 = CurrentDb
Set MyQry= MDB1.CreateQueryDef("", MySQL)
Set TBL2 = MyQry.OpenRecordset(dbOpenDynaset, dbSeeChanges)
CurrentView_列幅自動整列
Public Sub 列幅自動整列2()
With Forms![U060_Fma_FM]![U060_Fma_FM_SUBF02]
.Requery
If .Form.CurrentView <> 2 Then Exit Sub '0:デザインビュー 1:フォームビュー 2:データシートビュー 7:レイアウトビュー
.Form.RowHeight = 312 'データシートの高さ 15.6 1=20
Dim ctl As Control
For Each ctl In .Controls
If ctl.ControlType <> acLabel Then
If ctl.ControlType <> acSubform Then
ctl.ColumnWidth = -2
If InStr(ctl.Name, "備考") > 0 Then ctl.ColumnWidth = 4000
End If
End If
Next ctl
End With
DoCmd.CopyObject
Copyobject をやるとaccessが落ちる
DoCmd.SetWarnings False
DoCmd.CopyObject "", "_テーブル_見出しマスタ_FM_SUBF03_01", acForm, "_テーブル_見出しマスタ_FM_SUBF03_Template"
DoCmd.SetWarnings True
docmd.openquery_report
Private Sub Form_Open(Cancel As Integer)
DoCmd.Maximize
'Dim CompName, UsrName As String
'CompName = GetMyComputerName(): ' CompName = "SPOPT999" 'テストだす
'UsrName = NetUserName()
'comp_LoginUser名 = CompName & "/" & UsrName
DoCmd.SetWarnings False
DoCmd.OpenQuery "△11業種区分マスタWORK_削除qey", acViewNormal, acEdit
DoCmd.OpenQuery "△12業種区分マスタWORK_追加qey", acViewNormal, acEdit
DoCmd.SetWarnings True
End Sub
Private Sub 印刷処理_Click()
'プレビューのみ
message = MsgBox("印刷プレビューをしますか？", vbYesNo, "印刷処理")
If message = 6 Then
DoCmd.OpenReport "業種区分マスタ一覧_A4", acPreview, "", ""
Exit Sub
End If
message = MsgBox("印刷しますか？", vbYesNo, "印刷処理")
If message = 7 Then
Exit Sub
End If
'すぐに印刷
DoCmd.OpenReport "業種区分マスタ一覧_A4", acNormal, "", ""
End Sub
DOSコマンドを実行し、実行中は待つ
'DOSコマンドを実行し、実行中は待つ
'**************************************************
Dim dvfile
Dim OpenFlag1, OpenFlag2, OpenFlag3
Dim hShell, hProc, lExit, bret As Long
Dim ProcID As Integer
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Dim retval As Long
Dim ReturnValue As Variant
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Function ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
Call GetExitCodeProcess(proc.hProcess, ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
ExecCmd = ret&
End Function
'**************************************************
'---- すでに送信済みかどうかのチェック ---------
If Dir("z:\" & xdbfname & ".vdb") <> "" Or Dir("z:\" & xdbfname & ".xdb") <> "" Then
tmr2 = Time
tmrf = 3
サーバー更新の結果 = "サーバーに既に送信済みです。( " & xdbfname & ".xdb )"
Me.Repaint
MsgBox 選択xdb & " はファイルはサーバーに送信済みです。"
Exit Sub
End If
サーバー更新の結果 = ""
'サーバーに転送
ExecCmd "cmd /c copy q:\" & 選択xdb & " z:\" 'ExecCmd関数は処理が終わるまで待っています
zfbyte = FileLen("z:\" & 選択xdb)
Me.Repaint
If fbyte = zfbyte Then
tmrf = 1
サーバー更新の結果 = "サーバーに送信されました。( " & 選択xdb & ".xdb )"
MsgBox 選択xdb & " File copying was completed"
excelエクスポート
On Error GoTo Job_Err
DoCmd.TransferSpreadsheet acExport, 10, "クロス集計12表示qey", "x:\sample.xlsx", False, ""
Job_Exit:
Exit subn
Job_Err:
MsgBox Error$
Resume Job_Exit
EXCEL書込み方法
'EXCELファイルオープン
Dim FilePath As String
If HF = 0 Then FilePath = 保存場所ホルダ & "\" & 保存ファイル名
If HF = 1 Then FilePath = ひな型ファイル名
Dim MyXLS As Object 'Excel.Applicationオブジェクトの宣言
Dim MyBook As Object 'Excel.Workbookオブジェクトの宣言
Dim MySeets As Object 'Excel.WorkSheetオブジェクトの宣言
Set MyXLS = CreateObject("Excel.Application") '実行時バインディング
'既存のファイルを開く
If ExistFile(FilePath) Then
MyXLS.Workbooks.Open FileName:=FilePath
If HF = 0 Then MyXLS.Worksheets(1).Cells.Clear
Else
MyXLS.Workbooks.Add
End If
MyXLS.Visible = EXCEL可視 'EXCEL 可視/不可視
'表全体の形式
MyXLS.Selection.RowHeight = 20 '行の高さ
MyXLS.Selection.VerticalAlignment = xlCenter '上下中央揃え
Set MyBook = MyXLS.Workbooks(MyXLS.Workbooks.Count)
With MyBook
'シート名変更
.Worksheets(1).Name = Sheet_Name
'-------------------------------------------
II = 0
Y_Cell = .Sheets(1).Range(開始CELL).Column - 1 '横軸（列）
X_Cell = .Sheets(1).Range(開始CELL).Row - 1 '縦軸（業）
'Debug.Print X_Cell, Y_Cell
'EXCELへ見出しの書き込み
If 列見出しF = True Then
II = II + 1
JJ = 0
TBL1.MoveFirst
Do Until TBL1.EOF
JJ = JJ + 1
.Sheets(1).Cells(II + X_Cell, JJ + Y_Cell) = TBL1![見出し]
.Sheets(1).Cells(II + X_Cell, JJ + Y_Cell).EntireColumn.AutoFit
.Sheets(1).Cells(II + X_Cell, JJ + Y_Cell).Interior.ColorIndex = 34
.Sheets(1).Cells(II + X_Cell, JJ + Y_Cell).HorizontalAlignment = xlCenter
TBL1.MoveNext
Loop
End If
TBL2.MoveFirst
Do Until TBL2.EOF
II = II + 1
If (II / RecCnt) * 3000 <= 3000 Then
目盛りメーター.Width = (II / RecCnt) * 3000
Else
目盛りメーター.Width = 3000
End If
If (II / RecCnt) * 100 <= 100 Then
処理数値 = Format((II / RecCnt) * 100, "###") & "%"
Else
処理数値 = 100 & "%"
End If
'If 処理数値 <> CntOld Then DoEvents
CntOld = 処理数値
'EXCELへデータ書き込み
JJ = 0
TBL1.MoveFirst
Do Until TBL1.EOF
JJ = JJ + 1
.Sheets(1).Cells(II + X_Cell, JJ + Y_Cell) = TBL2(TBL1!見出し)
TBL1.MoveNext
Loop
TBL2.MoveNext
Loop
'データによる列幅の自動調整
JJ = 0
TBL1.MoveFirst
Do Until TBL1.EOF
JJ = JJ + 1
.Sheets(1).Cells(JJ + Y_Cell).EntireColumn.AutoFit
TBL1.MoveNext
Loop
'格子罫線を引く
With MyXLS
.Range(開始CELL).CurrentRegion.Select '表全体を選択
.Selection.Borders.LineStyle = xlContinuous '格子柄
' .Selection.Borders.Weight = xlHairline '極細線
' .Selection.Borders.Weight = xlThin '細線
' .Selection.BorderAround Weight:=xlMedium '外枠
End With
MyXLS.DisplayAlerts = False
If HF = 0 Then .SaveAs FileName:=FilePath
If HF = 1 Then
FilePath = 保存場所ホルダ & "\" & 保存ファイル名
.SaveAs FileName:=FilePath
End If
MyBook.Close
MyXLS.DisplayAlerts = True
End With
TBL1.Close
TBL2.Close
MyXLS.Quit
Set TBL1 = Nothing
Set TBL2 = Nothing
Set MDB1 = Nothing
Set MyXLS = Nothing
Exec_cmd
ExecCmd "q:\sns.bat q:\" & xdbfname 'ExecCmd関数は処理が終わるまで待っています
Public Function ExecCmd(cmdline$)
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
' Start the shelled application:
ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
' Wait for the shelled application to finish:
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
Call GetExitCodeProcess(proc.hProcess, ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
ExecCmd = ret&
End Function
-----------------------------------------
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
ExistFileモジュール
Option Compare Database
'ファイルの存在を確認する existとは「存在する」と言う意味
Function ExistFile(strFileName As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strFileName) Then
ExistFile = True
Else
ExistFile = False
End If
Set FSO = Nothing
End Function
ExistFolder
Function ExistFolder(Folder_Path As String) As Boolean
'フォルダが存在するかどうかを調べる
'Dir関数ではネットワークの長いパスに対応できない場合がある為
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(Folder_Path) Then
ExistFolder = True
Else
ExistFolder = False
End If
Set fso = Nothing
End Function
fhWnd
Private Function fhWnd(ctl As Control) As Long
On Error Resume Next
ctl.SetFocus
If Err Then
fhWnd = 0
Else
fhWnd = apiGetFocus
End If
On Error GoTo 0
End Function
FolderSearch
Public Sub FolderSearch(strTargetDir As String)
処理状況 = "指定ホルダよりファイルを書出し中": DoEvents
Dim f As Object, cnt As Long
Set MDB1 = CurrentDb
Set TBL2 = MDB1.OpenRecordset("●U060_清算書FILE_WORK", dbOpenDynaset, dbSeeChanges)
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(strTargetDir).Files
cnt = cnt + 1
追加:
If 清算書FMT種別 = "PDF" And InStr(f.Name, ".PDF") = 0 Then GoTo NextJOB
If 清算書FMT種別 = "EXCEL" And InStr(f.Name, ".XLSX") = 0 Then GoTo NextJOB
If InStr(f.Name, "$") > 0 Then GoTo NextJOB
TBL2.AddNew
TBL2![ファイル名] = f.Name
TBL2![パス名] = Replace(f.Path, f.Name, "")
TBL2![ファイルパス名] = f.Path
TBL2![清算書FMT種別] = 清算書FMT種別
TBL2.Update
NextJOB:
Next f
End With
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
End Sub
Public Sub FolderSearch1(strTargetDir As String)
'strTargetDir:探索対象のトップのフォルダ名を指定します
Dim fso As Object
Dim folder As Object
Dim subfolder As Object
Dim file As Object, 拡張子 As String
If 清算書FMT種別 = "PDF" Then 拡張子 = ".PDF"
If 清算書FMT種別 = "EXCEL" Then 拡張子 = ".XLSX"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(strTargetDir)
'フォルダ内のサブフォルダを列挙
'（サブフォルダがなければループ内は通らず）
For Each file In folder.Files
Debug.Print file.Path
Next
Stop
Exit Sub
'カレントフォルダ内のファイルを列挙し集計ファイル名に格納する
Set MDB1 = CurrentDb
Set TBL2 = MDB1.OpenRecordset("●U060_清算書FILE_WORK", dbOpenDynaset, dbSeeChanges)
For Each file In folder.Files
With file
'CreateObject("Shell.Application").ShellExecute .Path
' Debug.Print .Name, .Path, .Size
If Right(.Name, 4) <> 拡張子 Then GoTo Next_FileName
If TBL2.EOF And TBL2.BOF Then GoTo 追加
TBL2.FindFirst "ファイルパス名 = " & "'" & .Path & "'"
If TBL2.NoMatch = False Then GoTo Next_FileName
追加:
TBL2.AddNew
MsgBox .Name
TBL2![ファイル名] = .Name
TBL2![パス名] = Replace(.Path, .Name, "")
TBL2![ファイルパス名] = .Path
TBL2.Update
Next_FileName:
End With
Next file
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
End Sub
Form.Recordset.RecordCount
If Forms![U015_データ集計_FM]![U015_データ集計_FM_SUBF01].Form.Recordset.RecordCount = 0 Then
MsgBox "集計できるデータがありません。"
Exit Sub
End If
Form_ApplyFilter
Private Sub Form_ApplyFilter(Cancel As Integer, ApplyType As Integer)
Dim Qdf As QueryDef, MDB1 As Database, MySQL As String
If Forms![画面_FM]![画面_FM_SUBF02].Form.Filter = "" Then
MySQL = "SELECT [●画面_詳細WORK].* FROM ●画面_詳細WORK;" '規定値
Else
MySQL = "SELECT [●画面_詳細WORK].* From ●画面_詳細WORK WHERE (((" & _
Forms![画面_FM]![画面_FM_SUBF02].Form.Filter & ")=True));"
End If
Set MDB1 = CurrentDb
Set Qdf = MDB1.QueryDefs("U020_●画面_詳細WORK表示qey")
Qdf.SQL = MySQL
Set MDB1 = Nothing
Set Qdf = Nothing
Forms![画面_FM]![画面_FM_SUBF03].Form.RecordSource = "U020_●画面_詳細WORK_集計表示qey"
Forms![画面_FM]![画面_FM_SUBF03].Requery
End Sub
Form_Unload
Public Sub LocalWorkTable初期化()
WITH Forms![Prv_Frm]![Prv_Frm_SUBF02]
.Form.RecordSource = "●U013_DUMMY_WORK"
DoCmd.SetWarnings False
MySQL = "DELETE [LocalWorkTable].* FROM LocalWorkTable;"
DoCmd.RunSQL MySQL
DoCmd.SetWarnings True
If AutoNumberReset("LocalWorkTable", "登録ID") Then
.Form.RecordSource = "U013_LocalWorkTable_表示qey"
Else
MsgBox "「LocalWorkTable」の初期化に失敗しました。": Exit Sub
End If
.Form.Requery
END With
End if
Home EditionはQuery.exeがない
'Home EditionはQuery.exeがないので処理をしない
If InStr(OS_Edition, "Home") > 0 Then
Else
'Query.exeを使ってログオン状態を確認する
Set OBJ = New WshShell
Call OBJ.Run("CMD /C QUERY USER > " & F_path & "Logoninfo.txt", 2, WaitOnReturn:=True)
fileNo = FreeFile ' ファイルを開く為のファイル番号を取得
Open F_path & "Logoninfo.txt" For Input As #fileNo ' 指定されたファイルを開く
Do Until EOF(fileNo) ' ファイルがEOF(ファイルの終端)になるまでループをする
Line Input #fileNo, buffer ' ファイルから一行づつbufferに読み込む
If InStr(buffer, Usrname) > 0 Then
Session_Name = Mid(buffer, 24, 20)
Status_info = Mid(buffer, 47, 12)
Logon_DateTime = Mid(buffer, 66, 20)
Debug.Print Session_Name, Status_info, Logon_DateTime
End If
Loop
Close #fileNo
Call OBJ.Run("CMD /C DEL " & F_path & "Logoninfo.txt", 2, WaitOnReturn:=True)
End If
listboxの一行目を選択する
Private Sub Form_Load()
Me.lst_都道府県庁選択 = Me.lst_都道府県庁選択.ItemData(0)
End Sub
MySetPropty
Public Sub MySetPropty1()
Dim Pro_perty As Property
On Error GoTo Err
If IsNull(DEBUGF) Then DEBUGF = False
'データベースウィンドウの表示設定
Set MDB1 = CurrentDb
MDB1.Properties("StartupShowDBWindow") = DEBUGF
Set MDB1 = Nothing
Exit Sub
Err:
'起動時の設定がまだ設定されていない場合、エラーが発生するのでプロパティを作成し設定します。
Set Pro_perty = MDB1.CreateProperty("StartupShowDBWindow", dbBoolean, "False")
MDB1.Properties.Append Pro_perty
Set Pro_perty = Nothing
Set MDB1 = Nothing
End Sub
Public Sub MySetPropty2()
Dim Pro_perty As Property
On Error GoTo Err
If IsNull(DEBUGF) Then DEBUGF = False
'ショートカット キーを有効／無効
Set MDB1 = CurrentDb
MDB1.Properties("AllowSpecialKeys") = DEBUGF
Set MDB1 = Nothing
Exit Sub
Err:
'起動時の設定がまだ設定されていない場合、エラーが発生するのでプロパティを作成し設定します。
Set Pro_perty = MDB1.CreateProperty("AllowSpecialKeys", dbBoolean, "False")
MDB1.Properties.Append Pro_perty
Set Pro_perty = Nothing
Set MDB1 = Nothing
End Sub
Public Sub MySetPropty3()
Dim prpty As Property
Dim varPropType
On Error GoTo Err
varPropType = dbBoolean
'SHIFTキー／起動を出来なくする
Set MDB1 = CurrentDb
MDB1.Properties("AllowBypassKey") = DEBUGF
Set MDB1 = Nothing
Exit Sub
Err:
'起動時の設定がまだ設定されていない場合、エラーが発生するのでプロパティを作成し設定します。
Set prpty = MDB1.CreateProperty("AllowBypassKey", varPropType, "False")
MDB1.Properties.Append prpty
Set prpty = Nothing
Set MDB1 = Nothing
End Sub
openquery
DoCmd.SetWarnings False
DoCmd.OpenQuery "情報ORK_追加qey", acViewNormal, acEdit
DoCmd.SetWarnings True
openquery2
U020_●収容局支店表WORK_追加qey
DoCmd.SetWarnings False
DoCmd.CopyObject , "●クライアントPC情報起動日WORK", acTable, "●クライアントPC情報起動日WORK_Empty"
DoCmd.OpenQuery "Z000_クライアントPC情報起動日_追加qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z001_クライアントPC情報WORK削除F_更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z002_クライアントPC情報削除F_Rest更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z003_クライアントPC情報削除F_更新qey", acViewNormal, acEdit
'クライアントPC情報_削除
MySQL = "DELETE [◆クライアントPC情報].削除F FROM ◆クライアントPC情報 WHERE ((([◆クライアントPC情報].削除F)=True));"
DoCmd.RunSQL MySQL
DoCmd.SetWarnings True
OpenRecordset_MySQL
Public Sub 列順番再採番処理()
Dim ID_No As Long
MySQL = "SELECT [●W078_テーブル_見出しマスタWORK].* From ●W078_テーブル_見出しマスタWORK ORDER BY [●W078_テーブル_見出しマスタWORK].列順番;"
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset(MySQL)
If TBL1.BOF And TBL1.EOF Then
MsgBox "処理出来るデータがありません。"
Set MDB1 = Nothing
Set TBL1 = Nothing
End If
TBL1.MoveFirst
Do Until TBL1.EOF
TBL1.Edit
TBL1![仮列順番] = TBL1![列順番]
ID_No = ID_No + 1
TBL1![列順番] = ID_No
TBL1.Update
TBL1.MoveNext
Loop
Set MDB1 = Nothing
Set TBL1 = Nothing
Forms![W078_テーブル_見出しマスタ_FM]![W078_テーブル_見出しマスタ_FM_SUBF00].Requery
End Sub
Private Sub リンク再設定実行_Click()
Private Sub リンク再設定実行_Click()
If IsNull(ACCDB_FileName) Or ACCDB_FileName = "" Then
MsgBox "リンク先が設定されていません。", vbOKOnly, "リンク追加・再設定"
Exit Sub
End If
リンク数 = 0
リンク状態 = "再リンク中"
Set MDB1 = CurrentDb
Set TBL2 = Forms![Z997_リンクテーブル追加_FM]![Z997_リンクテーブル追加_FM_SUBF01].Form.RecordsetClone
If TBL2.EOF And TBL2.BOF Then
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
MsgBox "追加又は変更するテーブルがありません。", vbOKOnly, "リンク追加・再設定"
Exit Sub
End If
Dim TBLDef1 As TableDef, NewTBLDef As TableDef
Dim stMyTBL As String, stSVTbl As String
Dim LinkConnection As String
Dim TableName As String
Dim SourceTableName As String
TBL2.MoveFirst
Do Until TBL2.EOF
If TBL2![リンク実施F] = False Then GoTo 次のレコード:
'MS-Access accdb/accdeの場合
If TBL2![接続形態] = "Access" Then
'テーブルの存在チェック
If ExistTable(TBL2![テーブル名]) Then
MDB1.TableDefs.Delete TBL2![テーブル名] 'テーブルがある場合は一度削除
End If
'新規にリンクを貼る
On Error GoTo Link_Err
If IsNull(ACSパスワード) Or ACSパスワード = "" Then ACSパスワード = "ABCDEFGH"
Set TBLDef1 = MDB1.CreateTableDef(TBL2![テーブル名])
TBLDef1.Connect = ";DATABASE=" & ACCDB_FileName & ";PWD=" & ACSパスワード
TBLDef1.SourceTableName = TBL2![テーブル名]
MDB1.TableDefs.Append TBLDef1
TBL2.Edit
TBL2![接続状態] = "Link OK"
TBL2![リンク実施F] = False
TBL2.Update
リンク数 = リンク数 + 1
Link_Exit:
GoTo 次のレコード:
Link_Err:
TBL2.Edit
MsgBox Error
TBL2![接続状態] = "Link Error"
TBL2![リンク実施F] = True
TBL2.Update
Resume Link_Exit:
End If
次のレコード:
TBL2.MoveNext
Loop
TBL2.Close
If ACSパスワード = "ABCDEFGH" Then ACSパスワード = ""
Set TBL2 = Nothing
Set MDB1 = Nothing
Set TBLDef1 = Nothing
リンク状態 = "再リンク済み"
End Sub
QeyDef
Dim MySQLAs String
Dim MYDB1As .Database, TBL1 As dao.Recordset, Qry As QueryDef
Set MYDB1 = CurrentDb
Pxdb = Me.選択xdb
MySQL = "SELECT DISTINCT [Md5-hash].[ハッシュキー], [Md5-hash].[ファイル名日付] " & _
"FROM [Md5-hash] " & _
"WHERE (((InStr([ファイル名日付]," & Chr(34) & Pxdb & Chr(34) & "))>0));"
Set Qry = MYDB1.CreateQueryDef("", MySQL)
Set TBL1 = Qry.OpenRecordset
If TBL1.RecordCount > 0 Then
TBL1.MoveFirst
dl_hasheskey = TBL1![ハッシュキー]
dl_tm = TBL1![ファイル名日付]
End If
TBL1.Close
QueryDef 2
Dim myQuery As QueryDef,MySQL as string
MySQL = "SELECT 情報_詳細.* From 情報_詳細 WHERE (((情報_詳細.親登録ID)=" & TBL1![登録ID] & "));"
Set myQuery = MDB1.CreateQueryDef("", MySQL)
Set TBL3 = myQuery.OpenRecordset(dbOpenDynaset, dbSeeChanges)
TBL3.MoveLast
Debug.Print TBL3.RecordCount
Do Until TBL3.EOF
TBL3.MoveNext
Loop
TBL3.Close
Set TBL3 = Nothing
-----------------------------
'クエリを作成して選択クエリを実行する
Public Sub Sample()
Dim myDB As Database
Dim myRS As DAO.Recordset
Dim myQuery As QueryDef
Dim mySQL As String
'SQLステートメントを定義する
mySQL = "SELECT * FROM 社員テーブル;"
'カレントデータベースを変数に代入する
Set myDB = CurrentDb
'クエリを作成する
Set myQuery = myDB.CreateQueryDef("", mySQL)
'クエリを実行してレコードセットを開く
Set myRS = myQuery.OpenRecordset(dbOpenDynaset)
'レコードセットの内容を表示する
Do Until myRS.EOF
Debug.Print myRS!社員コード & " " & myRS!部署コード & " " _
& myRS!名前 & " " & myRS!入社年月日 & " " & myRS!職種
myRS.MoveNext
Loop
'レコードセットを閉じる
myRS.Close
End Sub
パラメーター（フォームの変数などを条件に使った場合）
パラメータークエリーをVBAから実行する場合は、改めてパラメーター名に値をセットしてあげます。
Dim myDb As Database
Dim myQdf As QueryDef
Dim myRs As Recordset
Set myDb = CurrentDb
Set myQdf = myDb.QueryDefs("Qry顧客検索")
With myQdf
'フォーム参照パラメータ名にコントロールの値をセット
.Parameters("[Forms]![Frm顧客登録]![顧客ID]") = Forms![Frm顧客登録]![顧客ID]
Set myRs = .OpenRecordset
End With
RecordsetClone
Set MDB1 = CurrentDb
Set TBL1 = Forms![画面_FM]![画面_FM_SUBF02].Form.RecordsetClone
Set TBL2 = MDB1.OpenRecordset("CSVファイル_WORK_TEMP", dbOpenDynaset, dbSeeChanges)
If TBL1.EOF And TBL1.BOF Then
TBL1.Close
Set MDB1 = Nothing
Set TBL1 = Nothing
Set TBL2 = Nothing
MsgBox "取得できるCSVファイル名の設定がありません。"
Exit Sub
End If
SetWarnings
DoCmd.SetWarnings False
MySQL = "DELETE [情報_WORK].* FROM 情報_WORK;"
DoCmd.RunSQL MySQL
MySQL = "DELETE [情報].* FROM 情報;"
DoCmd.RunSQL MySQL
DoCmd.SetWarnings True
Shift起動の有効無効
Function ap_DisableShift()
'This function disable the shift at startup. This action causes
'the Autoexec macro and Startup properties to always be executed.
'1.Access を起動します。
'2.新しいモジュールを作成し、次の2つの関数を追加します
'3.Visual Basic editor で、[表示] メニューの [イミディエイトウィンドウ] をクリックします。
'4.SHIFT キーを無効にする場合は、[イミディエイト] ウィンドウに ap_DisableShift と入力し、enter キーを押します。
' Shift キーを有効にする場合は、[イミディエイト] ウィンドウに ap_EnableShift と入力し、enter キーを押します。
'5.Accessを閉じます。閉じる際にモジュール名を「起動オプション」で保存します。
On Error GoTo errDisableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
'This next line disables the shift key on startup.
db.Properties("AllowByPassKey") = False
'The function is successful.
Exit Function
errDisableShift:
'The first part of this error routine creates the "AllowByPassKey
'property if it does not exist.
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, False)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Function ap_EnableShift()
'This function enables the SHIFT key at startup. This action causes
'the Autoexec macro and the Startup properties to be bypassed
'if the user holds down the SHIFT key when the user opens the database.
On Error GoTo errEnableShift
Dim db As DAO.Database
Dim prop As DAO.Property
Const conPropNotFound = 3270
Set db = CurrentDb()
'This next line of code disables the SHIFT key on startup.
db.Properties("AllowByPassKey") = True
'function successful
Exit Function
errEnableShift:
'The first part of this error routine creates the "AllowByPassKey
'property if it does not exist.
If Err = conPropNotFound Then
Set prop = db.CreateProperty("AllowByPassKey", _
dbBoolean, True)
db.Properties.Append prop
Resume Next
Else
MsgBox "Function 'ap_DisableShift' did not complete successfully."
Exit Function
End If
End Function
Trim関数
Sub Sample()
Dim myStr As String
myStr = " スキルアップ・問題解決なら モーグにおまかせ！ "
'---(1)LTrim
MsgBox "『" & myStr & "』 の先頭の半角スペースを削除します。" & vbCrLf & _
"『" & LTrim(myStr) & "』", , "LTrim関数"
'---(2)RTrim
MsgBox "『" & myStr & "』 の末尾の全角スペースを削除します。" & vbCrLf & _
"『" & RTrim(myStr) & "』", , "RTrim関数"
'---(3)Trim
MsgBox "『" & myStr & "』 の両端のスペースを削除します。" & vbCrLf & _
"『" & Trim(myStr) & "』", , "Trim関数"
End Sub
U000_Formオブジェクト_表示qey
SELECT MsysObjects.Name, Replace(Mid([name],InStr([name],"_")+1,50),"_FM","") AS 表題
FROM MsysObjects
WHERE (((MsysObjects.Name) Not Like "*SUB*" And (MsysObjects.Name) Not Like "*目次_*") AND ((MsysObjects.Type)=-32768))
ORDER BY MsysObjects.Name, MsysObjects.Name, MsysObjects.Name;
集計_FM_SUBF05
Option Compare Database
Option Explicit
Dim MDB1 As Database, TBL1 As Recordset, TBL2 As Recordset, TBL3 As Recordset
Dim RstCnt As Integer, II As Integer
Private Sub Form_Open(Cancel As Integer)
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset("履歴_クロス集計qey", dbOpenDynaset, dbSeeChanges)
TBL1.MoveLast
RstCnt = TBL1.RecordCount
If RstCnt > 60 Then MsgBox "年月が60以上あります。61個目から表示出来ません。"
For II = 0 To 60
If II < RstCnt Then
Me("fld" & II).ControlSource = TBL1.Fields(II).Name
Me("ラベルfld" & II).Caption = TBL1.Fields(II).Name
Else
Me("fld" & II).Visible = False
End If
Next II
VBAからバッチファイルを作る
VBAからバッチファイルを作る
Sub MakeBat()
Dim n As Long
Dim DesktopPath As String
n = FreeFile
DesktopPath = CreateObject("WScript.Shell").SpecialFolders("desktop")
Open DesktopPath & "\Test.bat" For Output As #n
Print #n, "Rem サーバー上からプログラムフォルダをダウンロードする。"
Print #n, "XCOPY \\hk001a24\va\data\ツール配信用\セグメント D:\セグメント /I/Y/F/E"
Print #n, "Rem フォルダへ移動する。"
Print #n, "D:"
Print #n, "CD D:\セグメント"
Print #n, "Rem ショートカットをデスクトップに作成する。"
Print #n, "csc.exe ""D:\セグメント\入力シート.xls""; ""?desktop?\セグメント入力シート.lnk"""
Print #n, "csc.exe ""D:\セグメント\出力シート.xls"" ""?desktop?\セグメント出力シート.lnk"""
Print #n, "csc.exe ""D:\セグメント\出力帳票"" ""?desktop?\セグメント出力帳票.lnk"""
Print #n, "exit"
Close #n
End Sub
VBAから別のファイルを開く
Private Sub 開く_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If IsNull(要求PATH) Then MsgBox "添付ファイル情報がありません": Exit Sub
If Shift = 0 Then CreateObject("Shell.Application").ShellExecute 要求PATH
If Shift = 1 Then Call FolderSearch(要求PATH)
End Sub
VBAでテーブルを開く
'利用者名の検索・表示
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset("◆利用者マスタ", dbOpenDynaset, dbSeeChanges)
'レコードの有無チェック
If TBL1.EOF And TBL1.BOF Then
'初めの1件目
TBL1.AddNew
TBL1![ログインユーザー名] = Usrname
TBL1![利用者名] = Usrname
TBL1![表示区分名] = "一般"
TBL1![管理者権限F] = False
TBL1![表示順番] = 99
TBL1.Update
End If
TBL1.MoveLast
RCnt = TBL1.RecordCount
TBL1.FindFirst "ログインユーザー名=" & "'" & Usrname & "'"
If TBL1.NoMatch Then
TBL1.AddNew
TBL1![ログインユーザー名] = Usrname
TBL1![利用者名] = Usrname
TBL1![表示区分名] = "一般"
TBL1![管理者権限F] = False
TBL1![表示順番] = 99
TBL1.Update
利用者名 = Usrname
表示区分名 = "一般"
管理者権限F = False
Else
利用者名 = TBL1![利用者名]
表示区分名 = TBL1![表示区分名]
管理者権限F = TBL1![管理者権限F]
End If
表示:
TBL1.Close
web画面の入力方法サンプル
フォーム上に Text1, Command1, WebBrowser1 を貼り付けて、
下のコードをコピー＆ペーストして、実行してみて下さい。
Command1 をクリックすると、 Text1 の内容が
Yahoo! の検索文字入力のテクストボックスに表示されます。
Option Explicit
Private wDisp As Object
Private Sub Form_Load()
WebBrowser1.Navigate2 "http://www.yahoo.co.jp/" '開きたいページ
End Sub
Private Sub Command1_Click()
Dim ooo As Object
Dim cw As String
For Each ooo In wDisp.Document.All.tags("input")
With ooo
cw = LCase(.getAttribute("type"))
Select Case cw
Case "text"
.Value = テキスト1
End Select
End With
Next ooo
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Set wDisp = pDisp
End Sub
x86_x64の切替え文2
'Access x64 x86の切替え
#If VBA7 And Win64 Then
'64bit版
Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal Hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function apiGetFocus Lib "User32" Alias "GetFocus" () As LongPtr
#Else
'32bit版
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function apiGetFocus Lib "user32" Alias "GetFocus" () As Long
#End If
x86_x64対応宣言
'Access x64 x86の切替え
#If VBA7 And Win64 Then
'64bit版
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function apiGetFocus Lib "user32" Alias "GetFocus" () As LongPtr
#Else
'32bit版
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare Function apiGetFocus Lib "user32" Alias "GetFocus" () As LongPtr
#End If
'マウスホイール関連
Private Const WM_VSCROLL As LongPtr = &H115& '↑↓スクロール
Private Const SB_LINEUP As LongPtr = &H0& '↑方向
Private Const SB_LINEDOWN As LongPtr = &H1& '↓方向
Private mLastWheeled As LongPtr '前回のホイール使用時刻(GetTickcCount)
x86_x64変更箇所
'ユーザー名を取得します。
#If VBA7 And Win64 Then
'64bit版
Private Declare PtrSafe Function WNetGetUser Lib "mpr" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
#Else
'32bit版
Private Declare Function WNetGetUser Lib "mpr" Alias "WNetGetUserA" (ByVal lpName As String, ByVal lpUserName As String, lpnLength As Long) As Long
#End If
'コンピュータ名の取得です。
#If VBA7 And Win64 Then
'64bit版
Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#Else
'32bit版
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
#End If
#If VBA7 And Win64 Then
'64bit版
Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#Else
'32bit版
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If
'マウスホイール関連
#If VBA7 And Win64 Then
'64bit版
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function apiGetFocus Lib "user32" Alias "GetFocus" () As Long
#Else
'32bit版
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function apiGetFocus Lib "user32" Alias "GetFocus" () As Long
#End If
アクションクエリー SQL文
'FtreeFullPathFileNameのデータ取込み前の削除処理
MySQL = "DELETE FtreeFullPathFileName.* FROM FtreeFullPathFileName;"
DoCmd.RunSQL MySQL
確認メッセージを表示させたくない場合は、事前に、
DoCmd.SetWarnings False
を実行しておくと、表示されなくなります。
元に戻すには、
DoCmd.SetWarnings True
です。
アクションクエリー後の件数を調べる
VBAからSQLコマンドを実行して処理件数を取得する
DatabaseオブジェクトのExecuteメソッドを利用して更新クエリ（SQLコマンド）を実行します。
その後、DatabaseオブジェクトのRecordsAffectedプロパティで処理件数を取得します。
Private Sub DoUpd()
Dim myDb As Database
Dim strsql As String
Set myDb = CurrentDb
strsql = "UPDATE テーブルA SET フラグ = 1 WHERE 条件 = TRUE"
'更新クエリを実行
myDb.Execute strsql
'RecordsAffectedプロパティで取得した処理件数を表示
MsgBox myDb.RecordsAffected & "件のレコードを更新しました", vbOKOnly + vbInformation
End Sub
インターネットエクスプローラー利用法
Microsoft Internet Controls 参照設定要
Dim ie As SHDocVw.InternetExplorer
Dim strURL As String
Set ie = New SHDocVw.InternetExplorer
strURL = "http://www.google.co.jp/"
ie.Visible = True
ie.Navigate strURL
Do Until (ie.Busy = False And ie.ReadyState = READYSTATE_COMPLETE)
DoEvents
Loop
ie.Document.all.q.Value = Me![場所] & " 住所"
ie.Document.Forms(0).Submit
Set ie = Nothing
エクセルで複数の条件で検索する
Private Sub 管理簿シート更新_Click()
MsgF = MsgBox("エクセルファイルの在庫管理簿を更新しますか？", vbYesNo, "在庫管理簿の更新 ")
If MsgF = vbNo Then Exit Sub
Set MDB1 = CurrentDb
Set TBL1 = Forms![U014_管理簿VO情報_FM]![U014_管理簿VO情報_FM_SUBF01].Form.RecordsetClone
If TBL1.EOF And TBL1.BOF Then
MsgBox "対象データがありません。"
TBL1.Close
Set TBL1 = Nothing
Set MDB1 = Nothing
Exit Sub
End If
If Nz(備品管理簿PATH) = "" Then MsgBox "検索用エクセルファイルのパスの設定がありません。": Exit Sub
If Nz(備品管理簿FILE) = "" Then MsgBox "検索用エクセルファイルのファイル名の設定がありません。": Exit Sub
Dim FilePath1 As String, FilePath2 As String
FilePath1 = 備品管理簿PATH & "\" & 備品管理簿FILE 'オリジナルファイル
If ExistFile(FilePath1) = False Then MsgBox "検索用エクセルファイルが存在しません。": Exit Sub
FilePath2 = 既定ホルダ & "\" & Form_Name & "_" & ユーザー名 & "_" & "_Temp_" & 管理簿エリア名 & "_" & 備品管理簿FILE '検索用ファイル
'検索用管理簿のチェック
If ExistFile(拡張BEDBFOL名 & "\" & 備品管理簿DB名) = False Then MsgBox "検索用エクセルファイルが存在しません。": Exit Sub
If Nz(管理簿TBL名) = "" Then MsgBox "テーブル名の設定がありません。": Exit Sub
'If ExistTableExt(管理簿TBL名) = False Then MsgBox "テーブルが存在しません。": Exit Sub
Dim strMDBFilePath As String, strMDBPath As String
strMDBFilePath = 拡張BEDBFOL名 & "\" & 備品管理簿DB名
DoCmd.OpenForm "U995_処理中_FM"
'変数設定
Dim MyXLS As Object 'Excel.Applicationオブジェクトの宣言
Dim MyBook As Object 'Excel.Workbookオブジェクトの宣言
Dim MySeets As Object 'Excel.WorkSheetオブジェクトの宣言
Dim StCount As Long, G_Sht As Long, II As Long, MsID As String
Dim FoundCell As Variant, FirstCell As Variant, Target As Variant 'Rangeまたはバリアント型(Variant)とする
Dim row_num As Long, clm_num As Long, strDate As String, strTime As String, SeiriKubun As String, Bikou As String
strDate = Format(Now(), "yyyymmdd")
strTime = Format(Now(), "hh:nn:ss")
Set MyXLS = CreateObject("Excel.Application") '実行時バインディング
With MyXLS
.Visible = EXL可視1 'EXCEL 可視/不可視
.Workbooks.Open FileName:=FilePath1
If .ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData 'フィルター解除
.ActiveSheet.Columns.Hidden = False '全ての列を表示
.ActiveSheet.Rows.Hidden = False '全ての行を表示
StCount = .Worksheets.Count
For II = 1 To StCount
If .Worksheets(II).Name = "" Then GoTo 次のシート
If InStr(.Worksheets(II).Name, 備品管理簿シート名) = 0 Then GoTo 次のシート
If InStr(.Worksheets(II).Name, 備品管理簿シート名) > 0 Then G_Sht = II '見出し名と同じ名前の該当するシート
次のシート:
Next II
Set MyBook = .Workbooks(.Workbooks.Count)
'管理簿特有処理 管理簿書式=1
Select Case 管理簿書式
Case 1
.Sheets(G_Sht).Select
.Columns("F:F").Select
TBL1.MoveFirst
Do Until TBL1.EOF
If Nz(TBL1![MSID]) = "" Then GoTo 次の発注番号
'If Nz(TBL1![STATUS]) <> "完了" Then GoTo 次の発注番号
MsID = Left(TBL1![MSID], 8)
Set FoundCell = .Range("F:F").Find(What:=MsID, SearchOrder:=xlByColumns, LookAt:=xlPart)
If FoundCell Is Nothing Then
Else
Set FirstCell = FoundCell
Set Target = FoundCell
'Debug.Print FirstCell.Address
row_num = .Range(FirstCell.Address).Row '行
clm_num = .Range(FirstCell.Address).Column '列
Debug.Print row_num
Debug.Print clm_num
'商品番号一致チェック
If TBL1![商品番号] = .Cells(row_num, 12).Value Then
'整理区分の一致チェック
SeiriKubun = .Cells(row_num, 14).Value & "-" & .Cells(row_num, 15).Value & "-" & .Cells(row_num, 16).Value & "-" & .Cells(row_num, 17).Value
If TBL1![整理区分] = SeiriKubun Then GoTo 書込み
End If
Do
Set FoundCell = .Cells.FindNext(FoundCell)
If FoundCell.Address = FirstCell.Address Then
Exit Do
Else
Set Target = FoundCell
'Debug.Print FoundCell.Address
row_num = .Range(FirstCell.Address).Row '行
clm_num = .Range(FirstCell.Address).Column '列
If TBL1![商品番号] = .Cells(row_num, 12).Value Then
'整理区分の一致チェック
SeiriKubun = .Cells(row_num, 14).Value & "-" & .Cells(row_num, 15).Value & "-" & .Cells(row_num, 16).Value & "-" & .Cells(row_num, 17).Value
If TBL1![整理区分] = SeiriKubun Then GoTo 書込み
End If
End If
Loop
GoTo 次の発注番号 '該当無し
書込み:
Bikou = .Cells(row_num, 32).Value
Bikou = Replace(Bikou, "立案指示番号:" & TBL1![発注番号] & "/", "")
If Nz(Bikou) <> "" Then Bikou = "/" & Bikou
.Cells(row_num, 32).Value = "立案指示番号:" & TBL1![発注番号] & Bikou '(備考 (32)
.Cells(row_num, 35).Value = TBL1![発注管理番号] '発注管理番号 (35)
If TimeStampF = True Then .Cells(row_num, 37).Value = strDate & " " & strTime '更新日(37)
End If
次の発注番号:
TBL1.MoveNext
Loop
Case 2 '別の管理簿書式
Case 3 '別の管理簿書式
Case 4 '別の管理簿書式
Case 5 '別の管理簿書式
End Select
'保存
.DisplayAlerts = False
.ActiveWorkbook.Save 'エクセルファイルへの書き出し
.ActiveWorkbook.Close
.DisplayAlerts = True
終了処理:
.Quit
End With
DoCmd.Close acForm, "U995_処理中_FM"
MsgBox "使用前管理簿の更新を完了しました。"
Set TBL1 = Nothing
Set MDB1 = Nothing
End Sub
エクセルファイルを開いて検索
'-----------------------------------------------------------------------------------------------------
エクセルファイルを開いて検索:
Dim MyXLS As Object 'Excel.Applicationオブジェクトの宣言
Dim MyBook As Object 'Excel.Workbookオブジェクトの宣言
Dim MySeets As Object 'Excel.WorkSheetオブジェクトの宣言
Dim FilePath As String, Cell_XY As String, StCount As Long
Dim FoundCell As Variant 'Rangeまたはバリアント型(Variant)とする
Dim row_num As Long, clm_num As Long, Area_Name As String
'On Error GoTo Err_Obj起動名_Click
FilePath = 既定ホルダ & "\" & Form_Name & "_" & ユーザー名 & "_" & "_Temp_" & 管理簿エリア名 & "_" & 備品管理簿FILE
Set MyXLS = CreateObject("Excel.Application") '実行時バインディング
With MyXLS
Set MyBook = .Workbooks.Open(FileName:=FilePath, ReadOnly:=True)
MyXLS.Visible = True 'EXCEL 可視/不可視
StCount = .Worksheets.Count
.ActiveSheet.ShowAllData
Cell_XY = 備品管理簿検索開始位置
Set FoundCell = .Range(Cell_XY).Find(What:=MSNM_ID2, SearchOrder:=xlByColumns, LookAt:=xlPart)
If FoundCell Is Nothing Then
保課コード = "該当無"
管理簿_MSNM= "該当無" 'MSNM
発生年 = "該当無" '工事竣工年月
使用月 = "該当無" '使用月
Else
'MSNM_ID検索
row_num = .Range(Cell_XY).Find(MSNM_ID2).Row '行
clm_num = .Range(Cell_XY).Find(MSNM_ID2).Column '列
保課コード = .Cells(row_num, 8).Value
管理簿_MSNM= .Cells(row_num, 6).Value 'MSNM
発生年 = .Cells(row_num, 24).Value '発生年
使用月 = .Cells(row_num, 28).Value '使用月
End If
MyBook.Close SaveChanges:=False
MyXLS.Quit
Set MyXLS = Nothing
End With
Exit_Fm起動名_Click:
Exit Sub
Err_Obj起動名_Click:
MsgBox Err.Description
Resume Exit_Fm起動名_Click
エクセルファイルを新規作成
①Excelファイルの新規作成と保存
Sub AccessVBAでExcelファイルの新規作成と保存()
Dim ExApp As Object
Set ExApp = CreateObject(“Excel.Application”)
ExApp.Visible = True
Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject(“Wscript.Shell”)
DesktopPath = WSH.SpecialFolders(“Desktop”)
FilePath = DesktopPath & “\作成したExcelファイル.xlsx”
ExApp.Workbooks.Add
With ExApp.Workbooks(ExApp.Workbooks.Count)
.Sheets(1).Cells(1, 1) = “aaaaa”
.SaveAs FileName:=FilePath
.Close
End With
ExApp.Quit
Set ExApp = Nothing
Set WSH = Nothing
End Sub
②既存Excelファイルの起動と上書き保存
Sub Accessで既存のExcelファイル起動と編集()
Dim ExApp As Object
Set ExApp = CreateObject(“Excel.Application”)
ExApp.Visible = True
Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject(“Wscript.Shell”)
DesktopPath = WSH.SpecialFolders(“Desktop”)
FilePath = DesktopPath & “\元Excelファイル.xlsx”
ExApp.Workbooks.Open FileName:=FilePath
With ExApp.Workbooks(ExApp.Workbooks.Count)
.Sheets(1).Cells(1, 1) = “aaaaa”
.Save
.Close
End With
ExApp.Quit
Set ExApp = Nothing
Set WSH = Nothing
End Sub
エクセル出力_一行しかない場合
.Range("A2").Select
.ActiveWindow.LargeScroll ToRight:=2
.Range("A2:AY2").Select
.Application.CutCopyMode = False
.Selection.Copy
If .Range("B2").End(xlDown).Row = 1048576 Then .Range("A2", "AY2").Select '一行しかない場合
If .Range("B2").End(xlDown).Row < 1048576 Then .Range("A2", "AY" & .Range("B2").End(xlDown).Row).Select
.Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Application.CutCopyMode = False
エクセル表の最大行数と列数
‘列数チェック
lngMaxCol = xlSheet.Cells(1, xlSheet.Columns.Count).End(xlToLeft).Column
‘最終行数の変数化
lngMaxRow = xlSheet.Cells(xlSheet.Rows.Count, 1).End(xlUp).Row
URL:https://yeh.jp/blog/access_vba_excel_row_col_get/
**********************************************************
'* Excelファイルの最終列最終行を取得
'**********************************************************
Public Function Func1341Nouki() As Boolean
On Error GoTo Err_Func1341Nouki
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim lngMaxRow As Long
Dim lngMaxCol As Long
'Excel
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("D:\****.XLS")
Set xlSheet = xlBook.Worksheets("Sheet1")
'列数チェック
lngMaxCol = xlSheet.Cells(1, xlSheet.Columns.Count).End(xlToLeft).Column
'最終行数の変数化
lngMaxRow = xlSheet.Cells(xlSheet.Rows.Count, 1).End(xlUp).Row
'Excel終了処理
xlBook.Close True
xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Func1341Nouki = True
MsgBox "inp"
Exit Function
Err_Func1341Nouki:
Func1341Nouki = False
End Function
エラー処理の書き方見本
Private Sub 場所変更_Click()
On Error GoTo Open_Err
DoCmd.OpenTable "Source_AccessFile_Location", acViewNormal, acEdit
Open_Exit:
Exit Sub
Open_Err:
MsgBox Error$
Resume Open_Exit
End Sub
オートフィルタをした場合のクエリー
'On Error GoTo Output_Err
Dim Qry_Name As String, Qdf As QueryDef, Path_File As String, Auto_Filter As String, Sort_by As String, Form_src As String
Path_File = 出力_パス & "\" & 出力_ファイル
Auto_Filter = Nz(Forms![W750_関連マスタメンテナンス_FM]![W750_関連マスタメンテナンス_FM_SUBF02].Form.Filter) 'フィルタ適用
Sort_by = Nz(Forms![W750_関連マスタメンテナンス_FM]![W750_関連マスタメンテナンス_FM_SUBF02].Form.OrderBy) '並べ替え
Qry_Name = "W750_関連マスタメンテナンス_FM_SUBF02_表示qey" '共通のクエリーオブジェクト
MySQL = Forms![W750_関連マスタメンテナンス_FM]![W750_関連マスタメンテナンス_FM_SUBF02].Form.RecordSource
Form_src = Forms![W750_関連マスタメンテナンス_FM]![W750_関連マスタメンテナンス_FM_SUBF02].SourceObject
'共通処理
If Auto_Filter <> "" Then MySQL = Replace(MySQL, ";", "") & " WHERE (((" & Auto_Filter & ")=True)) "
If Sort_by <> "" Then MySQL = MySQL & " ORDER BY " & Sort_by
MySQL = Replace(MySQL, "[" & Form_src & "].", "")
If InStr(MySQL, ";") = 0 Then MySQL = MySQL & ";"
Set MDB1 = CurrentDb
Set Qdf = MDB1.QueryDefs(Qry_Name)
Qdf.SQL = MySQL
Set MDB1 = Nothing
Set Qdf = Nothing
カレントパスを取得
'カレントパスを取得 参考URL
Debug.Print Application.CurrentProject.FullName
Debug.Print Application.CurrentProject.Name
↓
C:\Users\haga-001\Desktop\郵便番号.accdb
郵便番号.accdb
キー定数コード一覧
次の定数は、実際の値の代わりにコード内のどの部分でも使うことができます。
定数 値 内容
vbKeyLButton 0x1 マウスの左ボタン
vbKeyRButton 0x2 マウスの右ボタン
vbKeyCancel 0x3 Cancel キー
vbKeyMButton 0x4 マウスの右ボタン
vbKeyBack 0x8 BackSpace キー
vbKeyTab 0x9 Tab キー
vbKeyClear 0xC Clear キー
vbKeyReturn 0xD Enter キー
vbKeyShift 0x10 Shift キー
vbKeyControl 0x11 Ctrl キー
vbKeyMenu 0x12 Alt キー
vbKeyPause 0x13 Pause キー
vbKeyCapital 0x14 CapsLock キー
vbKeyEscape 0x1B Esc キー
vbKeySpace 0x20 Space キー
vbKeyPageUp 0x21 PageUp キー
vbKeyPageDown 0x22 PageDown キー
vbKeyEnd 0x23 End キー
vbKeyHome 0x24 Home キー
vbKeyLeft 0x25 ← キー
vbKeyUp 0x26 ↑ キー
vbKeyRight 0x27 → キー
vbKeyDown 0x28 ↓ キー
vbKeySelect 0x29 Select キー
vbKeyPrint 0x2A PrintScreen キー
vbKeyExecute 0x2B Execute キー
vbKeySnapshot 0x2C Snapshot キー
vbKeyInsert 0x2D Ins キー
vbKeyDelete 0x2E Del キー
vbKeyHelp 0x2F Help キー
vbKeyNumlock 0x90 NumLock キー
A ～ Z キーは、ASCII コードの A ～ Z に相当するものと同じです。
定数 値 内容
vbKeyA 65 A キー
vbKeyB 66 B キー
vbKeyC 67 C キー
vbKeyD 68 D キー
vbKeyE 69 E キー
vbKeyF 70 F キー
vbKeyG 71 G キー
vbKeyH 72 H キー
vbKeyI 73 I キー
vbKeyJ 74 J キー
vbKeyK 75 K キー
vbKeyL 76 L キー
vbKeyM 77 M キー
vbKeyN 78 N キー
vbKeyO 79 O キー
vbKeyP 80 P キー
vbKeyQ 81 Q キー
vbKeyR 82 R キー
vbKeyS 83 S キー
vbKeyT 84 T キー
vbKeyU 85 U キー
vbKeyV 86 V キー
vbKeyW 87 W キー
vbKeyX 88 X キー
vbKeyY 89 Y キー
vbKeyZ 90 Z キー
0 ～ 9 キーは、ASCII コードの 0 ～ 9 に相当するものと同じです。
定数 値 内容
vbKey0 48 0 キー
vbKey1 49 1 キー
vbKey2 50 2 キー
vbKey3 51 3 キー
vbKey4 52 4 キー
vbKey5 53 5 キー
vbKey6 54 6 キー
vbKey7 55 7 キー
vbKey8 56 8 キー
vbKey9 57 9 キー
次の定数は、テンキーの各キーを表します。
定数 値 内容
vbKeyNumpad0 0x60 0 キー
vbKeyNumpad1 0x61 1 キー
vbKeyNumpad2 0x62 2 キー
vbKeyNumpad3 0x63 3 キー
vbKeyNumpad4 0x64 4 キー
vbKeyNumpad5 0x65 5 キー
vbKeyNumpad6 0x66 6 キー
vbKeyNumpad7 0x67 7 キー
vbKeyNumpad8 0x68 8 キー
vbKeyNumpad9 0x69 9 キー
vbKeyMultiply 0x6A アスタリスク (*) キー
vbKeyAdd 0x6B プラス (+) キー
vbKeySeparator 0x6C Enter キー
vbKeySubtract 0x6D マイナス (-) キー
vbKeyDecimal 0x6E ピリオド (.) キー
vbKeyDivide 0x6F スラッシュ (/) キー
次の定数は、ファンクション キーの各キーを表します。
定数 値 内容
vbKeyF1 0x70 F1 キー
vbKeyF2 0x71 F2 キー
vbKeyF3 0x72 F3 キー
vbKeyF4 0x73 F4 キー
vbKeyF5 0x74 F5 キー
vbKeyF6 0x75 F6 キー
vbKeyF7 0x76 F7 キー
vbKeyF8 0x77 F8 キー
vbKeyF9 0x78 F9 キー
vbKeyF10 0x79 F10 キー
vbKeyF11 0x7A F11 キー
vbKeyF12 0x7B F12 キー
vbKeyF13 0x7C F13 キー
vbKeyF14 0x7D F14 キー
vbKeyF15 0x7E F15 キー
vbKeyF16 0x7F F16 キー
クエリーで連番
表示順番: DCount("*","Tableオブジェクト_表示qey","Name<=" & "'" & [NAME] & "'")
クエリーをVBAで開く
DoCmd.SetWarnings False
DoCmd.CopyObject , "クライアントPC情報起動日WORK", acTable, "クライアントPC情報起動日WORK_Empty"
DoCmd.OpenQuery "Z000_クライアントPC情報起動日_追加qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z001_クライアントPC情報WORK削除F_更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z002_クライアントPC情報削除F_Rest更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z003_クライアントPC情報削除F_更新qey", acViewNormal, acEdit
DoCmd.OpenQuery "Z000_クライアントPC情報_削除qey", acViewNormal, acEdit
DoCmd.SetWarnings True
クエリーを作成しそのファイルを開く
クエリを作成して選択クエリを実行する（但し、フォームから抽出条件をつける場合は、パラメータを追加する）
(Access 2000/2002)
●概要●
構文 expression. CreateQueryDef(name, sqltext)
設定項目 内容
expression Databaseオブジェクト［省略不可］
name クエリの名前を文字列で指定［省略可能］
sqltext SQLステートメントを指定［省略可能］
DatabaseオブジェクトのCreateQueryDefメソッドを使用して新しくQueryDefオブジェクトを作成します。引数に長さ0の文字列を指定すると、名前をつけずに一般的な名前のQueryDefオブジェクトを作成することができます。作成したQueryDefオブジェクトのOpenRecordsetメソッドを呼び出してRecordsetオブジェクトを作成します。
サンプルでは、SQLステートメントで「社員テーブル」のすべてのフィールドを選択します。すべてのフィールドを選択する場合は、１つ１つフィールドを指定するかわりに「*」（アスタリスク）を使用することができます。
●サンプル●
'クエリを作成して選択クエリを実行する
Public Sub Sample()
Dim myDB As Database
Dim myRS As DAO.Recordset
Dim myQuery As QueryDef
Dim mySQL As String
'SQLステートメントを定義する
mySQL = "SELECT * FROM 社員テーブル;"
'カレントデータベースを変数に代入する
Set myDB = CurrentDb
'クエリを作成する
Set myQuery = myDB.CreateQueryDef("", mySQL)
'クエリを実行してレコードセットを開く
Set myRS = myQuery.OpenRecordset(dbOpenDynaset)
'レコードセットの内容を表示する
Do Until myRS.EOF
Debug.Print myRS!社員コード & " " & myRS!部署コード & " " _
& myRS!名前 & " " & myRS!入社年月日 & " " & myRS!職種
myRS.MoveNext
Loop
'レコードセットを閉じる
myRS.Close
End Sub
●補足●
選択結果は［イミディエイト］ウィンドウに表示されます。
Access VBAのSQLステートメントでは、文末の「;」はつけてもつけなくてもかまいません。
クリックしたレコードに戻る
'クリックしたレコードに戻る
Me.Requery
DoCmd.GoToRecord , , acLast
DoCmd.GoToRecord , , acGoTo, Me.Form.CurrentRecord
クリップボードにコピーする
[備考].SetFocus
[備考].SelStart = 0
[備考].SelLength = Len([備考])
DoCmd.RunCommand acCmdCopy
クロス集計クエリーのフォーム
Forms![フォーム_FM]![フォーム_FM_SUBF03].Form.RecordSource = "クロス集計1qey"
Dim RstCnt As Integer, II As Integer
Dim ctl As Control
Set TBL3 = MDB1.OpenRecordset("クロス集計1qey", dbOpenDynaset, dbSeeChanges)
TBL3.MoveLast
RstCnt = TBL3.Fields.Count
If RstCnt > 100 Then MsgBox "年月が100以上あります。61個目から表示出来ません。"
For II = 0 To 100
Set ctl = Forms![フォーム_FM]![フォーム_FM_SUBF03]("fld" & II)
If II < RstCnt Then
ctl.ColumnHidden = False
Forms![フォーム_FM]![フォーム_FM_SUBF03]("fld" & II).ControlSource = TBL3.Fields(II).Name
Forms![フォーム_FM]![フォーム_FM_SUBF03]("ラベルfld" & II).Caption = TBL3.Fields(II).Name
Else
ctl.ColumnHidden = True
End If
Next II
TBL3.Close
コマンドボタン形状
コマンドボタン形状 = TBL2![コマンドボタン形状]
== Z999_システム設定_FM ==
'コマンドボタン形状の設定
ファイル参照.Shape = TBL2![コマンドボタン形状]
再読出し.Shape = TBL2![コマンドボタン形状]
設定登録.Shape = TBL2![コマンドボタン形状]
リボンナビ表示1.Shape = TBL2![コマンドボタン形状]
終了.Shape = TBL2![コマンドボタン形状]
== A001_目次_FM ==
'コマンドボタン形状の設定
ファイル参照.Shape = TBL2![コマンドボタン形状]
フィルター解除.Shape = TBL2![コマンドボタン形状]
目次更新.Shape = TBL2![コマンドボタン形状]
編集可否.Shape = TBL2![コマンドボタン形状]
リボンナビ表示1.Shape = TBL2![コマンドボタン形状]
終了.Shape = TBL2![コマンドボタン形状]
== B001_クライアントPC情報_FM ==
'コマンドボタン形状の設定
一覧更新.Shape = TBL2![コマンドボタン形状]
フィルター解除.Shape = TBL2![コマンドボタン形状]
編集可否.Shape = TBL2![コマンドボタン形状]
リボンナビ表示1.Shape = TBL2![コマンドボタン形状]
終了.Shape = TBL2![コマンドボタン形状]
== M001_利用者マスタ_FM ==
'コマンドボタン形状の設定
ファイル参照.Shape = TBL2![コマンドボタン形状]
再読出し.Shape = TBL2![コマンドボタン形状]
設定登録.Shape = TBL2![コマンドボタン形状]
リボンナビ表示1.Shape = TBL2![コマンドボタン形状]
終了.Shape = TBL2![コマンドボタン形状]
== M002_オブジェクト種別マスタ_FM ==
'コマンドボタン形状の設定
ファイル参照.Shape = TBL2![コマンドボタン形状]
再読出し.Shape = TBL2![コマンドボタン形状]
設定登録.Shape = TBL2![コマンドボタン形状]
リボンナビ表示1.Shape = TBL2![コマンドボタン形状]
終了.Shape = TBL2![コマンドボタン形状]
== M003_権限区分マスタ_FM ==
'コマンドボタン形状の設定
ファイル参照.Shape = TBL2![コマンドボタン形状]
再読出し.Shape = TBL2![コマンドボタン形状]
設定登録.Shape = TBL2![コマンドボタン形状]
リボンナビ表示1.Shape = TBL2![コマンドボタン形状]
終了.Shape = TBL2![コマンドボタン形状]
== Z000_終了画面_FM ==
'コマンドボタン形状の設定
終了.Shape = TBL2![コマンドボタン形状]
コンボボックスにフォーカスした時に一覧データを設定する方法
Private Sub 備考1_Enter()
備考1.RowSource = "SELECT 状況マスタ.状況, 状況マスタ.状況種別, 状況マスタ.表示順番, 状況マスタ.無効F FROM 状況マスタ WHERE (((状況マスタ.状況種別)=" & Chr(34) & _
"備考1" & Chr(34) & ") AND ((状況マスタ.無効F)=False)) ORDER BY 状況マスタ.表示順番;"
備考1.Requery
End Sub
コンボボックスにフォーカスした時に一覧データを設定する方法2
テキスト.RowSource = "SELECT 状況マスタ.状況, 状況マスタ.状況種別, 状況マスタ.表示順番, 状況マスタ.無効F FROM 状況マスタ WHERE (((状況マスタ.状況種別)=" & Chr(34) & _
"テキスト" & Chr(34) & ") AND ((状況マスタ.無効F)=False)) ORDER BY 状況マスタ.表示順番;"
テキスト.Requery
コンボボックスを使うときにはじめてデータを読み込む方法
Public Sub 受渡状況_一覧更新()
受渡状況.RowSource = "SELECT 状況マスタ.状況, 状況マスタ.状況種別, 状況マスタ.表示順番, 状況マスタ.無効F FROM 状況マスタ WHERE (((状況マスタ.状況種別)=" & Chr(34) & _
"受渡状況" & Chr(34) & ") AND ((状況マスタ.無効F)=False)) ORDER BY 状況マスタ.表示順番;"
受渡状況.Requery
End Sub
Public Sub SPV撤去処理者_一覧更新()
SPV撤去処理者.RowSource = "SELECT [◆利用者マスタ].利用者名, [◆利用者マスタ].表示順番 FROM ◆利用者マスタ ORDER BY [◆利用者マスタ].表示順番; "
SPV撤去処理者.Requery
End Sub
サブデータシートの展開と折り畳み
Public Sub 全て展開する()
Forms![情報_照会_FM]![情報_照会_FM_SUBF01].SetFocus
Forms![情報_照会_FM]![情報_照会_FM_SUBF01]![実施年度].SetFocus
'すべて展開コマンドを実行
DoCmd.RunCommand acCmdSubdatasheetExpandAll
End Sub
Private Sub 全て畳む_Click()
全て折り畳む
End Sub
Public Sub 全て折り畳む()
Forms![情報_照会_FM]![情報_照会_FM_SUBF01].SetFocus
Forms![情報_照会_FM]![情報_照会_FM_SUBF01]![実施年度].SetFocus
'すべて折りたたみコマンドを実行
DoCmd.RunCommand acCmdSubdatasheetCollapseAll
End Sub
サブテーブルの展開ボタン
Private Sub 全て展開_Click()
If 一覧表区分 = 3 Then 全て展開する
End Sub
Public Sub 全て展開する()
If Forms![Frm_FM]![Frm_FM_SUBF01].Form.Recordset.RecordCount = 0 Then Exit Sub
Forms![Frm_FM]![Frm_FM_SUBF01].SetFocus
Forms![Frm_FM]![Frm_FM_SUBF01]![年度].SetFocus
'すべて展開コマンドを実行
DoCmd.RunCommand acCmdSubdatasheetExpandAll
End Sub
'-----------------------------------------------------------------
Private Sub 全て畳む_Click()
If 一覧表区分 = 3 Then 全て折り畳む
End Sub
Public Sub 全て折り畳む()
If Forms![Frm_FM]![Frm_FM_SUBF01].Form.Recordset.RecordCount = 0 Then Exit Sub
Forms![Frm_FM]![Frm_FM_SUBF01].SetFocus
Forms![Frm_FM]![Frm_FM_SUBF01]![年度].SetFocus
'すべて折りたたみコマンドを実行
DoCmd.RunCommand acCmdSubdatasheetCollapseAll
End Sub
シリアル値を日付に戻す
式6: Format([完了日],"yyyy/mm/dd")
その他のウインドウ表示
DoCmd.CancelEvent 'イベントをキャンセルしてショートカットメニューを表示させない
If Button = acRightButton Then DoCmd.RunCommand acCmdMoreWindows '右クリック時のみ処理を実行
acCmdMoreWindows
ダイアログでファイル名を取得する
Private Sub ファイル参照2_Click()
'ツール(T) > 参照設定 > 「Microsoft Office 16.0 Object Library」にチェックを入れする
ACCDB_FileName = GetFileName()
'選択結果を評価
If Len(ACCDB_FileName) > 0 Then
Else
ACCDB_FileName = ""
End If
End Sub
標準モジュール名で以下を作成：Get_FileName 注意：GetFileName()と同じ名前にしてはダメ
Option Compare Database
Function GetFileName()
'ファイルを開くダイアログの例
Dim intRet As Integer
With Application.FileDialog(msoFileDialogOpen)
'ダイアログのタイトルを設定
.Title = "ファイルを開くダイアログの例"
'ファイルの種類を設定
.Filters.Clear
.Filters.Add "Microsoft Access データベース", "*.accdb"
.Filters.Add "すべてのファイル", "*.*"
'ファイルの種類の初期値を設定
.FilterIndex = 1
'複数ファイル選択を許可しない
.AllowMultiSelect = False
'初期パスを設定
.InitialFileName = CurrentProject.Path
'ダイアログを表示
intRet = .Show
If intRet <> 0 Then
'ファイルが選択されたとき
'そのフルバスを返り値に設定
GetFileName = Trim(.SelectedItems.item(1))
Else
'ファイルが選択されなければ長さゼロの文字列を返す
GetFileName = ""
End If
End With
End Function
ダイアログでホルダ名を取得する
Sub Sample1()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
MsgBox .SelectedItems(1)
End If
End With
End Sub
例文 基本情報システム
Private Sub ファイル参照_Click()
'ツール(T) > 参照設定 > 「Microsoft Office 16.0 Object Library」にチェックを入れする
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
フロントエンドファイルの保存場所 = .SelectedItems(1)
GoTo Exit_SUB
End If
End With
Exit_SUB:
End Sub
データシート選択表示
Dim ctl As Control
For Each ctl In Forms![情報_FM]![情報_FM_SUBF01].Controls
If ctl.ControlType <> acLabel Then
If ctl.Name = "処理状況" Then GoTo 次の処理
If ctl.Name = "基本情報_管理番号" Then GoTo 次の処理
If ctl.Name = "非表示F" Then GoTo 次の処理
If ctl.Name = "取得日時" Then GoTo 次の処理
If ctl.Name = "取得者" Then GoTo 次の処理
If ctl.Name = "登録日" Then GoTo 次の処理
If ctl.Name = "登録時間" Then GoTo 次の処理
If ctl.Name = "登録者" Then GoTo 次の処理
If ctl.Name = "登録ID" Then GoTo 次の処理
If ctl.Name = "年度" Then GoTo 次の処理
If InStr(ctl.Name, 情報区分) > 0 Then GoTo 次の処理
ctl.ColumnHidden = True
End If
次の処理:
Next ctl
データシート列全表示
Public Sub 列全表示()
Dim ctl As Control
For Each ctl In Forms![Uリスト情報_FM]![Uリスト情報_FM_SUBF01].Controls
If ctl.ControlType <> acLabel Then
ctl.ColumnHidden = False
End If
Next ctl
Forms![Uリスト情報_FM]![Uリスト情報_FM_SUBF01]!基本情報_ステータス.SetFocus
End Sub
データベースの追加
Dim TBLDef1 As TableDef, NewTBLDef As TableDef
Dim stMyTBL As String, stSVTbl As String
Dim LinkConnection As String
Dim TableName As String
Dim SourceTableName As String
Dim strConnect As String
Dim strMDBFilePath As String
For Each TBLDef In CurrentDb.TableDefs
If TBLDef.Attributes And TableDefAttributeEnum.dbAttachedTable Then
Set TBLDef = MDB1.TableDefs(TBLDef.Name) 'リンクテーブルの定義情報を開く
strConnect = TBLDef.Connect 'リンクテーブルの接続情報を取得
strMDBFilePath = Mid$(strConnect, InStr(strConnect, ";DATABASE=") + Len(";DATABASE=")) 'リンク先データベースファイル部分を取り出し
TBLDef.Name 'テーブル名
strMDBFilePath '接続先
End If
Next
'テーブルは一度削除
MDB1.TableDefs.Delete "履歴"
MDB1.TableDefs.Delete "履歴詳細"
'新規にリンクを貼る
Set TBLDef1 = MDB1.CreateTableDef("履歴" )
TBLDef1.Connect = ";DATABASE=" & ACCDB_FileName & ";PWD=ABCDEFGH"
TBLDef1.SourceTableName = "履歴"
MDB1.TableDefs.Append TBLDef1
Set TBLDef1 = MDB1.CreateTableDef("履歴詳細" )
TBLDef1.Connect = ";DATABASE=" & ACCDB_FileName & ";PWD=ABCDEFGH"
TBLDef1.SourceTableName = "履歴詳細"
MDB1.TableDefs.Append TBLDef1
Set MDB1 = Nothing
Set TBLDef1 = Nothing
データベースの追加原本
Private Sub リンク再設定実行_Click()
If IsNull(ACCDB_FileName) Or ACCDB_FileName = "" Then
MsgBox "リンク先が設定されていません。", vbOKOnly, "リンク追加・再設定"
Exit Sub
End If
リンク数 = 0
リンク状態 = "再リンク中"
Set MDB1 = CurrentDb
Set TBL2 = Forms![Z997_リンクテーブル追加_FM]![Z997_リンクテーブル追加_FM_SUBF01].Form.RecordsetClone
If TBL2.EOF And TBL2.BOF Then
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
MsgBox "追加又は変更するテーブルがありません。", vbOKOnly, "リンク追加・再設定"
Exit Sub
End If
Dim TBLDef1 As TableDef, NewTBLDef As TableDef
Dim stMyTBL As String, stSVTbl As String
Dim LinkConnection As String
Dim TableName As String
Dim SourceTableName As String
TBL2.MoveFirst
Do Until TBL2.EOF
If TBL2![リンク実施F] = False Then GoTo 次のレコード:
'MS-Access accdb/accdeの場合
If TBL2![接続形態] = "Access" Then
'テーブルの存在チェック
If ExistTable(TBL2![テーブル名]) Then
MDB1.TableDefs.Delete TBL2![テーブル名] 'テーブルがある場合は一度削除
End If
'新規にリンクを貼る
On Error GoTo Link_Err
If IsNull(ACSパスワード) Or ACSパスワード = "" Then ACSパスワード = "ABCDEFGH"
Set TBLDef1 = MDB1.CreateTableDef(TBL2![テーブル名])
TBLDef1.Connect = ";DATABASE=" & ACCDB_FileName & ";PWD=" & ACSパスワード
TBLDef1.SourceTableName = TBL2![テーブル名]
MDB1.TableDefs.Append TBLDef1
TBL2.Edit
TBL2![接続状態] = "Link OK"
TBL2![リンク実施F] = False
TBL2.Update
リンク数 = リンク数 + 1
Link_Exit:
GoTo 次のレコード:
Link_Err:
TBL2.Edit
MsgBox Error
TBL2![接続状態] = "Link Error"
TBL2![リンク実施F] = True
TBL2.Update
Resume Link_Exit:
End If
次のレコード:
TBL2.MoveNext
Loop
TBL2.Close
If ACSパスワード = "ABCDEFGH" Then ACSパスワード = ""
Set TBL2 = Nothing
Set MDB1 = Nothing
Set TBLDef1 = Nothing
リンク状態 = "再リンク済み"
End Sub
テーブルのオープン
Private Sub 場所変更_Click()
On Error GoTo Open_Err
DoCmd.OpenTable "Source_場所", acViewNormal, acEdit
Open_Exit:
Exit Sub
Open_Err:
MsgBox Error$
Resume Open_Exit
End Sub
テーブルのフィールド名を取得
Private Sub コマンド0_Click()
Dim db As Database
Dim rs As Recordset
Dim i As Long
Set db = CurrentDb()
Set rs = db.OpenRecordset("T-顧客マスター", dbOpenTable)
Me!テキスト1 = Null
For i = 0 To rs.Fields.Count - 1
Me!テキスト1 = Me!テキスト1 & rs.Fields(i).Name & vbCrLf
Next
Set rs = Nothing
Set db = Nothing
End Sub
テーブルのリンク先を変更する
Sub Sample01()
Dim db As DAO.Database, tb As DAO.TableDef
Set db = CurrentDb
Set tb = db.TableDefs("運送会社")
tb.Connect = ";DATABASE=C:¥Northwind.mdb;TABLE=運送会社"
tb.RefreshLink ' リンク情報の更新
End Sub
テーブルの検索と登録
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset(DB定義", dbOpenDynaset, dbSeeChanges)
TBL1.MoveLast
TBL1.FindFirst "契約都道府県名=" & "'" & 選択地域名 & "' and " & "利用区分=" & "'直近'"
If TBL1.NoMatch Then
完了報告データリストEXCEL_FILE = Null
Else
完了報告データリストEXCEL_FILE = TBL1![リストデータPATH]
End If
TBL1.Close
Set TBL1 = Nothing
Set MDB1 = Nothing
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset(DB定義", dbOpenDynaset, dbSeeChanges)
TBL1.MoveLast
TBL1.FindFirst "契約都道府県名=" & "'" & 選択地域名 & "' and " & "利用区分=" & "'直近'"
If TBL1.NoMatch Then
Else
TBL1.Edit
TBL1![リストデータPATH]= データリストEXCEL_FILE
TBL1.Update
End If
TBL1.Close
Set TBL1 = Nothing
Set MDB1 = Nothing
テーブルの再リンク
Private Sub リンク再設定実行_Click()
If ACCDB_FLAG = True Then
If IsNull(ACCDB_FileName) Or ACCDB_FileName = "" Then
MsgBox "リンク先が設定されていません。", vbOKOnly, "リンク再設定"
Exit Sub
End If
End If
If SQL_FLAG = True Then
If IsNull(SQL_FLAG) Or SQL_FLAG = "" Then
MsgBox "SQL Server リンク先が設定されていません。", vbOKOnly, "リンク再設定"
Exit Sub
End If
End If
リンク数 = 0
リンク状態 = "再リンク中"
Set MDB1 = CurrentDb
Set TBL2 = Forms![Z999_データ参照設定_FM]![Z999_データ参照設定_FM_SUBF01].Form.RecordsetClone
If TBL2.EOF And TBL2.BOF Then
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
MsgBox "リンク先を変更するテーブルがありません。", vbOKOnly, "リンク再設定"
Exit Sub
End If
Dim TBLDef1 As TableDef, TBLDef2 As TableDef, NewTBLDef As TableDef
Dim stMyTBL As String, stSVTbl As String
Dim LinkConnection As String
Dim TableName As String
Dim SourceTableName As String
TBL2.MoveFirst
Do Until TBL2.EOF
If TBL2![リンク実施F] = False Then GoTo 次のレコード:
'SQL Serverの場合
If TBL2![接続形態] = "SQL Server" Then
'処理開始
stMyTBL = TBL2![テーブル名]
LinkConnection = "ODBC;DRIVER=" & ODBCドライバ名 & ";SERVER=" & SQLサーバー名 & ";UID=" & ユーザーID & ";PWD=" & パスワード & ";APP=Microsoft Office" & ";DATABASE=" & 接続先データベース名
For Each TBLDef1 In MDB1.TableDefs
If InStr(TBLDef1.Connect, "ODBC") > 0 And TBLDef1.Name = stMyTBL Then
'変更するリンクテーブル名、ソース名を保存
TableName = TBLDef1.Name
SourceTableName = TBLDef1.SourceTableName
'既存のリンクテーブルの削除
MDB1.TableDefs.Delete TBLDef1.Name
'リンクテーブルの再作成
Set NewTBLDef = MDB1.CreateTableDef(TableName, dbAttachSavePWD, TableName, LinkConnection)
' Set NewTBLDef = MDB1.CreateTableDef(TableName)
NewTBLDef.Connect = LinkConnection
NewTBLDef.SourceTableName = SourceTableName
MDB1.TableDefs.Append NewTBLDef
MDB1.TableDefs(TableName).RefreshLink
'CREATE INDEX (ODBC リンク テーブルで擬似インデックスを作成する
MDB1.Execute "CREATE UNIQUE INDEX 登録ID " & "ON " & stMyTBL & " (登録ID) " & "WITH DISALLOW NULL;"
Set NewTBLDef = Nothing
End If
Next TBLDef1
TBL2.Edit
TBL2![接続状態] = "Link OK"
TBL2.Update
リンク数 = リンク数 + 1
SQLLink_Exit:
GoTo 次のレコード:
SQLLink_Err:
MsgBox Error
TBL2.Edit
TBL2![接続状態] = "Link Error"
TBL2.Update
Resume SQLLink_Exit:
End If
'MS-Access accdbの場合
If TBL2![接続形態] = "accdb" Then
Set TBLDef2 = MDB1.TableDefs(TBL2![テーブル名])
TBLDef2.Connect = ";DATABASE=" & ACCDB_FileName & ";TABLE=" & TBL2![テーブル名]
On Error GoTo Link_Err
TBLDef2.RefreshLink ' リンク情報の更新
TBL2.Edit
TBL2![接続状態] = "Link OK"
TBL2![リンク実施F] = False
TBL2.Update
リンク数 = リンク数 + 1
Link_Exit:
GoTo 次のレコード:
Link_Err:
TBL2.Edit
TBL2![接続状態] = "Link Error"
TBL2![リンク実施F] = True
TBL2.Update
Resume Link_Exit:
End If
次のレコード:
TBL2.MoveNext
Loop
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
Set TBLDef1 = Nothing
Set TBLDef2 = Nothing
リンク状態 = "再リンク済み"
If リンク数 = テーブル数 And リンク数 > 0 And テーブル数 > 0 Then データ参照設定情報登録
End Sub
テーブルの新規リンク
'------------------------------------------------------------
' マクロ1
'
'------------------------------------------------------------
Function マクロ1()
On Error GoTo マクロ1_Err
DoCmd.TransferDatabase acLink, "Microsoft Access", "\\NODE-61-FREENAS\public\AccessDB.2020\Accessdb.365\基本情報Menu.accdb", acTable, "目次マスタ", "目次マスタ", False
マクロ1_Exit:
Exit Function
マクロ1_Err:
MsgBox Error$
Resume マクロ1_Exit
End Function
テーブルの存在判定をして削除
'ACCESS VBA テーブルの存在判定をして削除
2011-06-16 11:46:22
テーマ：ACCESS VBA
If DCount("*", "MSysObjects", "[Name]='テーブル1'") > 0 Then
DoCmd.DeleteObject acTable, "テーブル1"
End If
テーブルの要素をフォームのフィールドに割り当てる
'テーブルの要素をフォームのフィールドに割り当てる
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset(テーブル名, dbOpenDynaset, dbSeeChanges)
RstCnt = TBL1.Fields.Count
For II = 0 To 100
If II < RstCnt Then
Frm1("fld" & II).ColumnHidden = False
Frm1("fld" & II).TextAlign = 1 '.TextAlign 左配置:1 中央配置:2 右配置:3 均等割り付け:4
If TBL1.Fields(II).Type = dbLong Then Frm1("fld" & II).TextAlign = 3
If TBL1.Fields(II).Type = dbSingle Then Frm1("fld" & II).TextAlign = 3
If InStr(TBL1.Fields(II).Name, "登録") > 0 And InStr(TBL1.Fields(II).Name, "ID") = 0 Then Frm1("fld" & II).TextAlign = 2
Frm1("fld" & II).ControlSource = TBL1.Fields(II).Name
Frm1("ラベルfld" & II).Caption = TBL1.Fields(II).Name
Else
Frm1("fld" & II).ColumnHidden = True
End If
Next II
テーブルをVBAで読み込む
'ログイン情報WORK登録／クライアントPC情報の日付と時間設定
Set MDB1 = CurrentDb
Set TBL2 = MDB1.OpenRecordset("ログイン情報WORK", dbOpenDynaset, dbSeeChanges)
'レコードの有無チェック
If TBL2.EOF And TBL2.BOF Then
'初めの1件目
TBL2.AddNew
TBL2![Login_User_Name] = Usrname
TBL2![Computer_Name] = CompName
TBL2![起動日] = Login_date
TBL2![起動時間] = Login_time
Else
TBL2.MoveFirst
TBL2.Edit
TBL2![Login_User_Name] = Usrname
TBL2![Computer_Name] = CompName
TBL2![起動日] = Login_date
TBL2![起動時間] = Login_time
End If
TBL2.Update
TBL2.Close
Login_date = Date$
Login_time = Time$
Login_date_time = Login_date & " " & Login_time
Me.Repaint
テキスト_カンマ単位_ADODB_Streem
With CreateObject("ADODB.Stream")
If Forms![Z101_技術資料_FM]![文字CODE区分] = 1 Then .Charset = "_autodetect_all"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 2 Then .Charset = "SJIS"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 3 Then .Charset = "UTF-8"
.Open
.LoadFromFile Target
Do Until .EOS
buf = .ReadText(-2)
i = i + 1
tmp = Split(buf, ",")
For j = 0 To UBound(tmp)
Forms![Z101_技術資料_FM]![技術資料内容] = Forms![Z101_技術資料_FM]![技術資料内容] & tmp(j) & vbCrLf
Debug.Print Forms![Z101_技術資料_FM]![技術資料内容]
Next j
Loop
.Close
End With
テキストのSQL文からクエリを作成する方法
テキストで書かれたSQL文を元に、Accessデータベース内にクエリオブジェクトを新規作成する方法です。
次のサンプルコードでは、変数strSQLにSQL文を代入しています。またstrQryNameに作成するクエリ名を指定しています。
そしてそれを「CreateQueryDef」メソッドの引数に与えて実行することによって、クエリが作成されます。
Dim strSQL As String
Dim strQryName As String
strSQL = "SELECT 商品コード, 商品名 FROM mtbl商品マスタ"
strQryName = "クエリ1"
CurrentDb.CreateQueryDef strQryName, strSQL
一般的なアプリケーション内の処理としてクエリを新規作成する機会はあまりないと思いますが、
たとえば他のデータベースエンジン用のSQL文をテキストベースで加工して、それから一気にAccess用のクエリとして生成するような、開発時の作業には役立つ場面があるかもしれません。
テキストファイルの件数
Dim fso As Scripting.FileSystemObject
Dim ts As Scripting.TextStream, JJ As Long, j As Long
'CSVファイルの件数を調べる
Set ts = fso.OpenTextFile(Path_File, ForAppending)
T_RecCnt = ts.Line
ts.Close
Set ts = Nothing
テキストボックスの名前を変数で使う
For i = 1 to 5
example = Me.Controls("txtbox" & i)
Next i
テキストボックス内でマウススクロールする
Option Compare Database
Option Explicit
' Windows が起動してからの経過ミリ秒数を取得
Private Declare PtrSafe Function GetTickCount Lib "Kernel32" () As Long
' テキストボックス用
Private Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare PtrSafe Function apiGetFocus Lib "user32" _
Alias "GetFocus" () As Long
Private Const WM_VSCROLL As Long = &H115& ' 垂直スクロール
Private Const SB_LINEUP As Long = &H0& ' 上方向
Private Const SB_LINEDOWN As Long = &H1& ' 下方向
Private mLastWheeled As Long ' 前回のホイール使用時刻(GetTickCount)
Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
On Error GoTo erh
mLastWheeled = GetTickCount
If Not Me.ActiveControl Is Me.[技術資料内容] Then Exit Sub
Dim i As Integer
Dim hWnd As Long: hWnd = fhWnd(Me.ActiveControl)
For i = 1 To Abs(Count)
SendMessage hWnd, WM_VSCROLL, IIf(Count < 0, SB_LINEUP, SB_LINEDOWN), 0&
Next
erh:
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
Cancel = (GetTickCount - mLastWheeled) < 100 ' ホイール使用後0.1秒未満レコード移動不可
End Sub
Private Function fhWnd(ctl As Control) As Long
On Error Resume Next
ctl.SetFocus
If Err Then
fhWnd = 0
Else
fhWnd = apiGetFocus
End If
On Error GoTo 0
End Function
'*********** Code End *************
テキスト一気読込_ADODB_Streem
With CreateObject("ADODB.Stream")
If Forms![Z101_技術資料_FM]![文字CODE区分] = 1 Then .Charset = "_autodetect_all"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 2 Then .Charset = "SJIS"
If Forms![Z101_技術資料_FM]![文字CODE区分] = 3 Then .Charset = "UTF-8"
.Open
.LoadFromFile Target
Do Until .EOS
buf1 = .ReadText(-2) '一行ずつ読込みは-2、一気読込みは-1、省略の場合は-1となります。
buf1 = Replace(buf1, vbLf, "")
buf1 = Replace(buf1, vbCrLf, "")
RecCnt = RecCnt + 1
Loop
.Close
End With
テキスト書込み_ADODB.STREAM
参考URL:http://officetanaka.net/excel/vba/file/file11.htm
Sub Sample1()
Dim Target As String
Target = "D:\Work\Sample.txt"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText "名前1", 1
.SaveToFile Target, 2
.Close
End With
End Sub
------------------------------------------------------------
第2引数を省略するか「0」を指定すると、末尾に改行コードを書き込みません。
Sub Sample1()
Dim Target As String
Target = "D:\Work\Sample.txt"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText "名前1", 0
.WriteText "名前2"
.WriteText "名前3"
.SaveToFile Target, 2
.Close
End With
End Sub
------------------------------------------------------------
WriteTextメソッドが、書き込む命令です。第2引数に「1」を指定すると、書き込むデータ(上では"名前1")の後ろに改行コードを書き込みます。
Sub Sample1()
Dim Target As String
Target = "D:\Work\Sample.txt"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText "名前1", 1
.WriteText "名前2", 1
.WriteText "名前3", 1
.SaveToFile Target, 2
.Close
End With
End Sub
-------------------------------------------------------------
SaveToFileメソッドが、ファイルに保存する命令です。第1引数には、保存したいファイルの名前を指定します。第2引数は、ちょっとややこしいです。
値 指定したファイルが存在する場合 指定したファイルが存在しない場合
1 実行時エラーになる 作成して書き込む
2 上書きする 作成して書き込む
テキスト読込
《テキストファイルを開く》
Sub Openfile()
Dim cdir As String
Dim tdir As String
Dim tfi As String
Dim filenum As Integer
cdir = ThisWorkbook.Path
tfi = "sample.txt"
tdir = cdir & "\" & tfi
filenum = FreeFile
Open tdir For Input As #filenum
End Sub
テキスト読込_ADODB_Streem
With CreateObject("ADODB.Stream")
.Charset = "SJIS" '"UTF-8" "_autodetect_all"
.Open
.LoadFromFile Path_File
Do Until .EOS
buf1 = .ReadText(-2)
buf1 = Replace(buf1, vbLf, "")
buf1 = Replace(buf1, vbCrLf, "")
RecCnt = RecCnt + 1
Loop
.Close
End With
テキスト読込ADODB_Stream
'http://officetanaka.net/excel/vba/file/file10.htm
Sub Sample3()
Dim buf As String, Target As String, i As Long
Dim tmp As Variant, j As Long
Target = "D:\Work\UTF-8のテキスト.csv"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile Target
Do Until .EOS
buf = .ReadText(-2)
i = i + 1
tmp = Split(buf, ",")
For j = 0 To UBound(tmp)
Cells(i, j + 1) = tmp(j)
Next j
Loop
.Close
End With
End Sub
テキスト連続読込ADODB_Stream
With CreateObject("ADODB.Stream")
.Charset = "SJIS"
.Open
.LoadFromFile Path_File
Do Until .EOS
buf1 = .ReadText(-2)
buf1 = Replace(buf1, vbLf, "")
buf1 = Replace(buf1, vbCrLf, "")
buf1 = Replace(buf1, "|", "_")
buf1 = Replace(buf1, "`", "'")
buf2 = Replace(buf1, Chr(34) & "," & Chr(34), "`") '「","」文字を「`」に一時変更する
buf2 = Replace(buf2, ",", "|") 'ダブルクォーテーションに囲まれた「,」を「|」に一時変更する
buf2 = Replace(buf2, "`", Chr(34) & "," & Chr(34)) '「`」→「","」
buf2 = Replace(buf2, Chr(34) & "|", Chr(34) & ",") '「|」→「,」
buf2 = Replace(buf2, vbLf, "")
buf2 = Replace(buf2, vbCrLf, "")
'テーブルに書き込む
Loop
.Close
End With
パラメータークエリについて
パラメータークエリについて
Parameters("sql分に含まれるフォーム!コントロール名")=実際の値に相当するフォーム!コントロール名（入っている値）
If 移動区分 = 1 Then
'MySQL = "SELECT リスト情報.契約地域名, リスト情報.年月 FROM リスト情報;"
MySQL = "SELECT リスト情報.発注番号 From リスト情報 WHERE (((" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_契約地域名]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_契約地域名] = [契約地域名], 1, 0))) = 1) And ((" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_年月]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_年月] = [年月], 1, 0))) = 1));"
End If
If 移動区分 = 2 Then
'MySQL = "SELECT リスト情報_過去.契約地域名, リスト情報_過去.年月 FROM リスト情報_過去;"
MySQL = "SELECT リスト情報_過去.発注番号 FROM リスト情報_過去 WHERE (((ち" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_契約地域名]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_契約地域名] = [契約地域名], 1, 0))) = 1) And ((" & _
"IIf(Nz([Forms]![U017_データ情報_現過_FM]![対象_年月]) = " & Chr(34) & Chr(34) & ", 1, " & _
"IIf([Forms]![U017_データ情報_現過_FM]![対象_年月] = [年月], 1, 0))) = 1));"
End If
Set MDB1 = CurrentDb
Set MyQry = MDB1.CreateQueryDef("", MySQL)
With MyQry
.Parameters("[Forms]![U017_データ情報_現過_FM]![対象_契約地域名]") = [Forms]![U017_データ情報_現過_FM]![対象_契約地域名]
.Parameters("[Forms]![U017_データ情報_現過_FM]![対象_年月]") = [Forms]![U017_データ情報_現過_FM]![対象_年月]
End With
ひな型の一部領域に罫線、フォント、文字位置を設定する
Private Sub ファイルを開く_Click()
'ファイルの存在チェック
If IsNull(データリストEXCEL_FILE) Then MsgBox "エクセルファイルが選択されていません。": Exit Sub
If ExistFile(データリストEXCEL_FILE) = False Then MsgB'表全体の形式
For G_Sht = 1 To STCount
With MyXLS
'罫線を描画 '表全体を選択
.Sheets(G_Sht).Select
.Range("B7").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.Borders.LineStyle = xlContinuous '格子柄
.Selection.HorizontalAlignment = xlCenter '[横位置]
'表全体の形式
.Selection.Font.Name = "Meiryo UI" 'フォント
.Selection.Font.Size = 10 'フォントサイズ
.Selection.RowHeight = 18 '行の高さ
.Selection.VerticalAlignment = xlCenter '上下中央揃え
.Selection.HorizontalAlignment = xlRight '[右位置]
' .Selection.EntireColumn.AutoFit
.Range("B7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlCenter
.Range("C7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlLeft
.Range("D7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlCenter
If .Range("E6").Value = "個別" Then
.Range("E7").Select
.Range(.Selection, .Selection.End(xlDown)).Select
.Selection.HorizontalAlignment = xlCenter
End If
End With
Next G_Sht
ox "エクセルファイルが存在しません。": Exit Sub
CreateObject("Shell.Application").ShellExecute データリストEXCEL_FILE
End Sub
'標準プロシージャに以下を作成 名前：Exist_File
Option Compare Database
'ファイルの存在を確認する existとは「存在する」と言う意味
Public Function ExistFile(strFileName As String) As Boolean
ExistFile = (Len(Dir(strFileName, vbHidden)) > 0)
End Function
ファイルの存在チェックと開く
Private Sub ファイルを開く_Click()
'ファイルの存在チェック
If IsNull(データリストEXCEL_FILE) Then MsgBox "エクセルファイルが選択されていません。": Exit Sub
If ExistFile(データリストEXCEL_FILE) = False Then MsgBox "エクセルファイルが存在しません。": Exit Sub
CreateObject("Shell.Application").ShellExecute データリストEXCEL_FILE
End Sub
ファイルの存在の有無
Sub Sample2()
Const Target As String = "C:\Sample\Book2.xlsx"
If Dir(Target) <> "" Then
Workbooks.Open Target
Else
MsgBox Target & vbCrLf & "が存在しません"
End If
End Sub
Dir関数が返すのは、パスを含まないファイル名です。たとえば「Dir("C:\Sample\Book2.xlsx")」は「Book2.xlsx」を返します。この特徴を利用して、フルパスのファイル名を、パス部分とファイル名部分に分割することもできます。詳しくは、下記ページをご覧ください。
フルパスをパスとファイル名に分ける
なお、ファイルの存在確認は、FileSystemObjectのFileExistsメソッドでも可能ですが、特に理由がない限り、簡単なDir関数を使えばいいでしょう。ちなみに、FileExistsメソッドは次のようにします。
Sub Sample3()
Const Target As String = "C:\Sample\Book2.xlsx"
With CreateObject("Scripting.FileSystemObject")
If .FileExists(Target) Then
Workbooks.Open Target
Else
MsgBox Target & vbCrLf & "が存在しません"
End If
End With
End Sub
FileSystemObjectのFileExistsメソッドは、引数に指定したファイルが存在するときTrueを返します。
ファイルの読み書き(Shift-JIS版)
'ファイルの読み込み(Shift-JIS版)
Dim fileNo As Integer ' ファイル番号
Dim buffer As String ' 一時的に文字列を格納
fileNo = FreeFile ' ファイルを開く為のファイル番号を取得
Open "C:\excel_vba_22_sjis.txt" For Input As #fileNo ' 指定されたファイルを開く
Do Until EOF(fileNo) ' ファイルがEOF(ファイルの終端)になるまでループをする
Line Input #fileNo, buffer ' ファイルから一行づつbufferに読み込む
Debug.Print buffer ' 読み込んだ一行をイミディエイトに出力
Loop
Close #fileNo
'ファイルの書き込み(Shift-JIS版)
Dim fileNo As Integer ' ファイル番号
fileNo = FreeFile ' ファイルを開く為のファイル番号を取得
Open "Sjisの書き込みテスト.txt" For Output As #fileNo ' 指定されたファイルを開く(ない場合は作成する)
Print #fileNo, "エクセル講座" ' 一行毎に文字列を書き込む
Print #fileNo, "http://www.petitmonte.com/excel/excel.html"
Close #fileNo
ファイルの読み書きUTF-8版)
ファイルの読み込み(UTF8版)
Dim buf As String, Target As String, i As Long
Dim tmp As Variant, j As Long
Target = "D:\Work\UTF-8のテキスト.csv"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile Target
Do Until .EOS
buf = .ReadText(-2)
i = i + 1
tmp = Split(buf, ",")
For j = 0 To UBound(tmp)
Cells(i, j + 1) = tmp(j)
Next j
Loop
.Close
End With
ファイルの書き込み(UTF8版)
例1）
Dim Stream As Object
Set Stream = CreateObject("ADODB.Stream") ' VB標準のADODB.Streamオブジェクトを作成する
With Stream
.Charset = "UTF-8" ' ストリームの文字コードをUTF8に設定する
.Type = 2 ' ファイルのタイプ(1:バイナリ 2:テキスト)
.Open ' ストリームを開く
.WriteText "エクセル講座" & vbCrLf ' ストリームの保存形式をテキスト形式にする
.SaveToFile ("utf8の書き込みテスト.txt"), 2 ' ストリームに名前を付けて保存する(1は新規作成 2は上書き保存)
.Close ' ストリームを閉じる
End With
Set Stream = Nothing
例2）
Dim Target As String
Target = "D:\Work\Sample.txt"
With CreateObject("ADODB.Stream") ' VB標準のADODB.Streamオブジェクトを作成する
.Charset = "UTF-8" ' ストリームの文字コードをUTF8に設定する
.Open
.WriteText "田中", 0
.WriteText "鈴木"
.WriteText "佐藤"
.SaveToFile Target, 2
.Close
End With
'WriteTextメソッドが、書き込む命令です。
'第2引数に「1」を指定すると、書き込むデータ(上では"田中")の後ろに改行コードを書き込みます。
'第2引数を省略するか「0」を指定すると、末尾に改行コードを書き込みません。
ファイル参照
Private Sub 場所_Click()
'サブフォームを編集可能にする
編集可否.Caption = "一覧編集中"
With Forms![M001_利用者マスタ_FM]![M001_利用者マスタ_FM_SUBF01]
.Form.AllowAdditions = True '追加
.Form.AllowDeletions = True '削除
.Form.AllowEdits = True '更新
End With
'「ファイルを開く」ダイアログボックスで、ファイルのフルパスを取得する
'(参照ダイアログボックス使用) 2010/07/17 pPoy http://www.nurs.or.jp/~ppoy/access/access/acEt042.html
Dim objFileDialog As Object 'FileDialog
Dim stTitle As String 'タイトル
Dim stPath As String 'ファイルのフルパス
Dim stFilter1 As String 'ファイルのフィルタ
Dim stFilter2 As String 'ファイルのフィルタ
Dim stInitialFileName As String '初期フォルダパス
Const msoFileDialogFilePicker = 3 'ファイルの参照
stTitle = "ファイル名の取得" '★
stInitialFileName = "d:\" '★
Set objFileDialog = _
Application.FileDialog(msoFileDialogFilePicker)
With objFileDialog
'ダイアログボックスのタイトル
.Title = stTitle
'複数ファイル選択不可
.AllowMultiSelect = False
'初期フォルダパス
.InitialFileName = stInitialFileName
'ファイルの種類設定
.Filters.Clear
.Filters.Add "すべてのファイル", "*.*"
.Filters.Add "Word", "*.docx"
.Filters.Add "Excel", "*.xlsx"
.Filters.Add "Excelマクロ", "*.xlmx"
.Filters.Add "テキスト", "*.txt"
If .Show = False Then
'キャンセル時
GoTo Exit_SUB
Else
'★選択時フルパス表示
stPath = .SelectedItems(1)
JJ = 0: FF = 0
JJ = Len(stPath)
For II = JJ To 1 Step -1
If Mid(stPath, II, 1) = "\" Then
FF = II
Forms![M001_利用者マスタ_FM]![M001_利用者マスタ_FM_SUBF01]!場所 = Mid(stPath, 1, FF) 'パスを取得
Forms![M001_利用者マスタ_FM]![M001_利用者マスタ_FM_SUBF01]!オブジェクト名 = Mid(stPath, FF + 1, JJ - FF) 'ファイル名を取得
Forms![M001_利用者マスタ_FM]![M001_利用者マスタ_FM_SUBF01]!表題 = Mid(stPath, FF + 1, JJ - FF) '表題の取得
File_string = Mid(stPath, FF + 1, JJ - FF) 'ファイル名を取得
GoTo 抽出終了
End If
Next II
抽出終了:
xx = 0
For xx = 1 To 255
If Mid(File_string, xx, 1) = "." Then
Forms![M001_利用者マスタ_FM]![M001_利用者マスタ_FM_SUBF01]!表題 = Mid(File_string, 1, xx - 1)
Forms![M001_利用者マスタ_FM]![M001_利用者マスタ_FM_SUBF01]!オブジェクト種別 = Mid(File_string, xx + 1, 5)
End If
Next xx
' MsgBox stPath, vbOKOnly '取得したファイルパス+ファイル名の表示
End If
End With
Exit_SUB:
Set objFileDialog = Nothing
Me.Requery
End Sub
フィールド名を変数にする
TBL1.Collect(str_Title(KK)) = .Cells(II + 1, clm_num).Value
フィルター処理
Private Sub Form_ApplyFilter(Cancel As Integer, ApplyType As Integer)
Dim Qdf As QueryDef, MDB1 As Database, MySQL As String
If Forms![LIST情報_FM]![LIST情報_FM_SUBF02].Form.Filter = "" Then
MySQL = "SELECT [●LIST情報_詳細WORK].* FROM ●LIST情報_詳細WORK;" '規定値
'クエリが複雑の場合は、別途表示クエリーを使えばよい。
Else
MySQL = "SELECT [●LIST情報_詳細WORK].* From ●LIST情報_詳細WORK WHERE (((" & _
Forms![LIST情報_FM]![LIST情報_FM_SUBF02].Form.Filter & ")=True));"
End If
Set MDB1 = CurrentDb
Set Qdf = MDB1.QueryDefs("U020_●LIST情報_詳細WORK表示qey")
Qdf.SQL = MySQL 'フィルタを有効にする
Set MDB1 = Nothing
Set Qdf = Nothing
Forms![LIST情報_FM]![LIST情報_FM_SUBF03].Form.RecordSource = "U020_●LIST情報_詳細WORK_集計表示qey"
Forms![LIST情報_FM]![LIST情報_FM_SUBF03].Requery
End Sub
フィルター表示_リボンのフィルタと同じ機能
DoCmd.CancelEvent 'イベントをキャンセルしてショートカットメニューを表示させない
If Button = acRightButton Then DoCmd.RunCommand acCmdFilterMenu '右クリック時のみ処理を実行
フィルタメニュー
Private Sub 担当_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
DoCmd.CancelEvent 'イベントをキャンセルしてショートカットメニューを表示させない
If Button = acRightButton Then DoCmd.RunCommand acCmdFilterMenu '右クリック時のみ処理を実行
End Sub
フォームが開いているか確認し開いていたら閉じる
'MENUフォームが開いていたら閉じる
Dim varRet As Variant
varRet = SysCmd(acSysCmdGetObjectState, acForm, "A001_目次_FM")
' If varRet = 1 Then DoCmd.Close acForm, "A001_目次_FM"
フォームタイトルの設定呼び出し
Set TBL2 = MDB1.OpenRecordset("◇システム設定", dbOpenDynaset, dbSeeChanges)
TBL2.FindFirst "拡張機能システムのタイトル名=" & "'" & Left(CurrentProject.Name, InStr(1, CurrentProject.Name, "_ver", vbBinaryCompare) - 1) & "'"
If TBL2.NoMatch Then
目次_Form = Null
'既定の参照ホルダ =NULL
Else
目次_Form = TBL2![目次_FormName]
'既定の参照ホルダ = TBL2![既定の参照ホルダ]
'タイトルの色
If TBL2![見出色F] = True Then
Dim Gradno As Long
If Nz(TBL2![gSTILE]) = "" Then Gradno = リボンナビ表示切替1.Gradient
If Nz(TBL2![gSTILE]) <> "" And Nz(TBL2![gSTILE]) <= 26 Then Gradno = TBL2![gSTILE]
If Nz(TBL2![見出し前景色]) <> "" Then リボンナビ表示切替1.ForeColor = TBL2![見出し前景色]
If Nz(TBL2![見出し背景色]) <> "" Then リボンナビ表示切替1.BackColor = TBL2![見出し背景色]
リボンナビ表示切替1.Gradient = Gradno
End If
End If
TBL2.Close
Set MDB1 = Nothing
Set TBL2 = Nothing
フォームに侮ｦされているデータをVBAで開く
Set MDB1 = CurrentDb
Set TBL2 = Forms![Z999_データ参照設定_FM]![Z999_データ参照設定_FM_SUBF01].Form.RecordsetClone
If TBL2.EOF And TBL2.BOF Then
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
MsgBox "リンク先を変更するテーブルがありません。", vbOKOnly, "リンク再設定"
Exit Sub
End If
Dim TableDef As TableDef, TBLDef As TableDef
TBL2.MoveFirst
Do Until TBL2.EOF
Debug.Print TBL2![テーブル名]
If TBL1![リンク実施F] = False Then GoTo 次のレコード:
次のレコード:
TBL2.MoveNext
Loop
TBL2.Close
Set TBL2 = Nothing
Set MDB1 = Nothing
Set TableDef = Nothing
Set TBLDef = Nothing
フォームのパラメーターの呼出しと保存
テーブル形式:●U076_df_parameter
Public Sub 画面初期値の呼出し()
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset("●U076_df_parameter", dbOpenDynaset, dbSeeChanges)
If TBL1.EOF And TBL1.BOF Then GoTo 終了
TBL1.MoveFirst
検索開始位置 = TBL1![検索開始位置]
検索対象ファイルパス名 = TBL1![検索対象ファイルパス名]
検索対象ファイル名 = TBL1![検索対象ファイル名]
DB初期化F = TBL1![DB初期化F]
DATA153ファイルパス名 = TBL1![DATA153ファイルパス名]
DATA153ファイル名 = TBL1![DATA153ファイル名]
EXCEL可視 = TBL1![EXCEL可視]
保存場所ホルダ名 = TBL1![保存場所ホルダ名]
保存ファイル名 = TBL1![保存ファイル名]
終了:
TBL1.Close
Set TBL1 = Nothing
Set MDB1 = Nothing
End Sub
Public Sub 画面初期値の書込み()
Set MDB1 = CurrentDb
Set TBL1 = MDB1.OpenRecordset("●U076_df_parameter", dbOpenDynaset, dbSeeChanges)
If TBL1.EOF And TBL1.BOF Then TBL1.AddNew: GoTo 書込み
TBL1.MoveFirst
TBL1.Edit
書込み:
TBL1![検索開始位置] = 検索開始位置
TBL1![検索対象ファイルパス名] = 検索対象ファイルパス名
TBL1![検索対象ファイル名] = 検索対象ファイル名
TBL1![DB初期化F] = DB初期化F
TBL1![DATA153ファイルパス名] = DATA153ファイルパス名
TBL1![DATA153ファイル名] = DATA153ファイル名
TBL1![EXCEL可視] = EXCEL可視
TBL1![保存場所ホルダ名] = 保存場所ホルダ名
TBL1![保存ファイル名] = 保存ファイル名
TBL1.Update
終了:
TBL1.Close
Set TBL1 = Nothing
Set MDB1 = Nothing
End Sub
Page updated
Google Sites
Report abuse