遅延バインデバイデングによるEXCELの開き方(Excel2013対応も）
Dim myXLS As Object
Dim myWKB As Object
Dim myWKS As Object
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim cmd As New ADODB.Command
Set conn = CurrentProject.Connection
Set cmd.ActiveConnection = conn
On Error Resume Next
Set myXLS = CreateObject("Excel.Application.15")
Set myXLS = CreateObject("Excel.Application")
Set myWKB =
myXLS.Workbooks.Add
Set myWKS = myWKB.Worksheets("sheet1")
myWKS.Application.Visible = True
myXLS.Visible = True '--------------------------Workbookを開く
'******* 時間を秒して保存
Dim a
Dim b
Dim c As Long
Dim d As Long
Dim cc As Long
Dim dd As Long
Dim w As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim ww As Long
Dim xx As Long
Dim yy As Long
Dim zz As Long
Set cmd.ActiveConnection = cnn
Set rs3 = New ADODB.Recordset
Set rs2 = New ADODB.Recordset
b = Me.一覧.Column(0)
a = Format(Me.月度, "yyyy/mm")
rs3.Open "SELECT KND_TANCOD,KND_SYUGYO,KND_KYUSYU from D_勤怠 where KND_TANCOD = " & Val(b) & "", cnn, , , adCmdText
If rs3.EOF Then Exit Sub
With cmd
.CommandText = "DELETE * FROM 勤怠実績 WHERE 月度 = '" & Me.月度 & "' and 社員番号 = '" & b & "'"
.CommandType = adCmdText
.Execute
End With
rs3.MoveFirst
' Debug.Print Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "h,n,s") ' "**:**:**" を "**,**,**" に変換
Do Until rs3.EOF
Set rs4 = New ADODB.Recordset
rs4.Open "SELECT * from 勤怠実績 where 月度 = '" & Me.月度 & "' and 社員番号 = '" & b & "'", cnn, , , adCmdText
w = (Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "h")) * 3600
x = (Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "n")) * 60
y = (Format(Nz(rs3.Fields("KND_SYUGYO"), 0), "s"))
z = w + x + y
c = z
ww = (Format(Nz(rs3.Fields("KND_KYUSYU"), 0), "h")) * 3600
xx = (Format(Nz(rs3.Fields("KND_KYUSYU"), 0), "n")) * 60
yy = (Format(Nz(rs3.Fields("KND_KYUSYU"), 0), "s"))
zz = ww + xx + yy
d = zz
If rs4.EOF Then
rs2.Open "勤怠実績", cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
rs2.AddNew
rs2("社員番号") = Trim(Str(rs3.Fields("KND_TANCOD")))
rs2("月度") = Me.月度
rs2("勤怠集計数") = c
rs2("祭日勤怠数") = d
rs2.Update
rs2.Close
Else
cc = c + rs4.Fields("勤怠集計数")
dd = d + rs4.Fields("祭日勤怠数")
With cmd
.CommandText = "UPDATE 勤怠実績 SET 勤怠集計数 = " & cc & ",祭日勤怠数 = " & dd & " WHERE 月度 = '" & Me.月度 & "' and 社員番号 = '" & rs4.Fields("社員番号") & "'"
.CommandType = adCmdText
.Execute
End With
End If
rs3.MoveNext
Loop
'*******
和暦の例（Function側）
Public Function wareki(warekitosi As Variant, warekituki As Variant, warekihi As Variant) As Variant
Dim B
Dim c
Dim D
Dim x
Dim cc
Dim dd
Dim y
' Dim warekitosi
' Dim warekituki
' Dim warekihi
B = Date
Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Set cn = CurrentProject.Connection
rs.CursorType = adOpenStatic
rs.LockType = adLockOptimistic
rs.LockType = adLockOptimistic
rs.Open "SELECT * from 元号 order by 始年月日", cn, , , adCmdText
If rs.EOF = True Then
End If
rs.MoveFirst
Do Until rs.EOF
D = rs.Fields("始年月日")
c = rs.Fields("元号")
rs.MoveNext
If rs.EOF Then
y = c
Exit Do
End If
dd = rs.Fields("始年月日")
cc = rs.Fields("元号")
If B >= D And B < dd Then
y = c
Exit Do
End If
Loop
x = Year(B) - Year(D) + 1
If x = "1" Then x = "元"
warekitosi = y & x & "年"
warekituki = Format(B, "mm")
warekihi = Format(B, "dd")
End Function
和暦の例（sub側）
Call wareki(warekitosi, warekituki, warekihi)
Call xwareki(xwarekitosi, xwarekituki, xwarekihi)
Call ywareki(ywarekitosi, ywarekituki, ywarekihi)
Me.年.RowSourceType = "Value List"
' D = Format(DateAdd("yyyy", -1, Date), "GGGEE年") & ";" & Format(Date, "GGGEE年") & ";" & Format(DateAdd("yyyy", 1, Date), "GGGEE年") & ";"
D = xwarekitosi & ";" & warekitosi & ";" & ywarekitosi & ";"
印刷のキャンセル時
If rs2.EOF Then Exit Sub
If Me.選択1 = "供養" Then
DoCmd.OpenReport "案内書棚経", acPreview
Else
DoCmd.OpenReport "案内書", acPreview
End If
If MsgBox("印刷してもよいですか", vbYesNo) = vbNo Then
DoCmd.Close
Else
On Error GoTo ErrRtn
DoCmd.RunCommand acCmdPrint
DoCmd.Close
Set rs31 = New ADODB.Recordset
rs31.Open "SELECT * FROM 追善一時 where 確認 = yes ", cn, , , adCmdText
If Not rs31.EOF Then
rs31.MoveFirst
Do Until rs31.EOF
If rs31.Fields("印刷") = "0" Then
B = "1"
Else
B = "2"
End If
With cmd
.CommandText = "UPDATE 実施 SET 印刷 = '" & B & "' where 実施ID = " & rs31.Fields("実施ID") & ""
.CommandType = adCmdText
.Execute
End With
With cmd
.CommandText = "UPDATE 追善一時 SET 印刷 = '" & B & "' where 追善ID = " & rs31.Fields("追善ID") & ""
.CommandType = adCmdText
.Execute
End With
rs31.MoveNext
Loop
Else
End If
Me.Form.Requery
End If
Me.Refresh
ErrRtn:
DoCmd.Close acReport, "案内書棚経", acSaveNo
DoCmd.Close acReport, "案内書", acSaveNo
氏名で、 「姓 名」と「姓名」のダブリチエック機能
Dim x
Dim xx
Dim y
Dim yy
Dim cn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rs4 As New ADODB.Recordset
Dim rs3 As New ADODB.Recordset
Dim rs31 As New ADODB.Recordset
Dim rs32 As New ADODB.Recordset
Set cn = CurrentProject.Connection
Set rs32 = New ADODB.Recordset
rs32.Open "SELECT * from 過去帳 where 地区 = '" & Me.地区 & "'", cn, , , adCmdText
If Not rs32.EOF Then
rs32.MoveFirst
Do Until rs32.EOF
y = Replace(rs32.Fields("俗名"), " ", "")
yy = Replace(Me.俗名, " ", "")
If y = yy Then
MsgBox "登録済です"
Exit Sub
End If
rs32.MoveNext
Loop
Else
End If
Set rs3 = New ADODB.Recordset
rs3.Open "SELECT * from 過去帳 where 地区 = '" & Me.地区 & "' and 俗名 = '" & Replace(Me.俗名, " ", "") & "'", cn, , , adCmdText
If Not rs3.EOF Then
x = Replace(rs3.Fields("俗名"), " ", "")
xx = Replace(Me.俗名, " ", "")
If x = xx Then
MsgBox "登録済です"
Exit Sub
End If
Else
End If
Set rs4 = New ADODB.Recordset
rs4.Open "SELECT * from 過去帳 where 地区 = '" & Me.地区 & "' and 俗名 = '" & Me.俗名 & "'", cn, , , adCmdText
If Not rs4.EOF Then
If rs4.Fields("俗名") = Me.俗名 Then
MsgBox "登録済です"
Exit Sub
End If
Else
End If
Set rs31 = New ADODB.Recordset
rs31.Open "SELECT * from 過去帳一時 where 地区 = '" & Me.地区 & "' and 俗名 = '" & Me.俗名 & "'", cn, , , adCmdText
If Not rs31.EOF Then
If rs31.Fields("俗名") = Me.俗名 Then
MsgBox "入力済です"
Exit Sub
End If
Else
End If
秒単位の集計結果を [hh]:nn:ss 書式に変換するには、
標準モジュールに下記の関数を作成しておいて
Public Function Second2TimeStr(v As Long) As String
Dim t As Long
Second2TimeStr = Format(v Mod 60, "\:00")
t = v \ 60
Second2TimeStr = Format(t Mod 60, "\:00") & Second2TimeStr
t = t \ 60
Second2TimeStr = Format(t, "00") & Second2TimeStr
End Function
Second2TimeStr([集計値])
とします。
集計値が160114秒なら、44:28:34 が返ります。
印刷プレビユー時のON ERROR GO TO の例
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cnn = CurrentProject.Connection
Set rs = New ADODB.Recordset
rs.Open "SELECT * from tmp_受注 where 選択 = True ", cnn, , , adCmdText
If rs.EOF = True Then Exit Sub
ARG = rs.Fields("見積番号")
DoCmd.OpenReport "受注印刷再", acPreview
If MsgBox("印刷してもよいですか", vbYesNo) = vbNo Then
DoCmd.Close
Else
On Error GoTo ErrRtn
DoCmd.RunCommand acCmdPrint
DoCmd.Close
cnn.Execute "UPDATE 受注表 SET 印刷日='" & Format(Now(), "gee/mm/dd") & "' WHERE 見積番号='" & ARG & "' ;"
cnn.Close: Set cnn = Nothing
End If
ErrRtn:
DoCmd.Close acReport, "受注印刷再", acSaveNo
リストボックスの選択対象の削除
Dim element
For Each element In Me.一覧.ItemsSelected
'選択解除
Me.一覧.Selected(element) = False
Next
ON ERROR GO TO の例
On Error GoTo ErrRtn
DoCmd.Echo False
DoCmd.SetWarnings False
DoCmd.OpenQuery "3_Add(出荷テーブル)"
DoCmd.OpenQuery "3_UpDate(受注テーブル)"
DoCmd.OpenQuery "1_Delete(在庫)"
DoCmd.OpenQuery "1_Add(在庫)"
DoCmd.SetWarnings True
DoCmd.Echo True
MsgBox "登録しました"
Exit Sub
ErrRtn:
DoCmd.SetWarnings True
DoCmd.Echo True
MsgBox "登録できませんでした"
Exit Sub
Resume Next
