VBA [VBA]
Function outputHtml(ByVal nextdate As String, ByVal sec As Integer)
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim SQL As String
Dim str As String
Dim datFile As String
Dim header, footer As String
Dim title As String
Dim sec_name As String
Dim file_name As String
Select Case sec
Case 1
sec_name = "AAAA"
file_name = "AAAA.html"
Case 2
sec_name = "BBBB"
file_name = "BBBB.html"
Case 3
sec_name = "CCCC"
file_name = "CCCC.html"
Case Else
MsgBox "選択してください"
Exit Function
End Select
header = "<!DOCTYPE html><html lang='ja'><head><meta charset='SJIS'><title>事項</title>" & Chr(13) & Chr(10)
header = header & "<link href='style.css' rel='stylesheet' type='text/css'></head>"
datFile = Application.CurrentProject.Path & "\" & file_name
Set CN = CurrentProject.Connection
Set RS = New ADODB.Recordset
SQL = "SELECT * FROM Q_ WHERE 期限 >= #" & nextdate & "# AND " & sec_name & "=true"
RS.Open SQL, CN, adOpenStatic, adLockOptimistic
str = header & "<body><h1>" & Forms!outputHtml!txt_date.Value & "の事項</h1>" & Chr(13) & Chr(10)
str = str & "<table><tr><th style='width:500px;'>事項</th><th style='width:80px;'>登録者</th><th>期限</th></tr>" & Chr(13) & Chr(10)
If RS.EOF = False Then
Do Until RS.EOF
str = str & "<tr><td><b>■" & RS!件名 & "</b><br><br>" & RS!内容 & "</td><td>" & RS!姓 & "</td><td>" & Format(RS!期限, "mm/dd") & "</td></tr>" & Chr(13) & Chr(10)
RS.MoveNext
Loop
End If
str = str & "</table>" & Chr(13) & Chr(10)
str = str & "<div class='timestamp'>" & Now & "</div>" & Chr(13) & Chr(10)
str = str & "</body></html>"
Open datFile For Output As #1
Print #1, str
Close #1
RS.Close: Set RS = Nothing
CN.Close: Set CN = Nothing
result = MsgBox("Htmlの出力が完了しました。", vbInformation)
End Function
Function openPreview()
Dim rename As String
Dim sec As Integer
Dim sec_name As String
Dim stropenargs As String
Dim strdate As String
rename = "R_周知"
sec = Forms![outputHtml]![sel_sec]
Select Case sec
Case 1
sec_name = "AAAA"
Case 2
sec_name = "BBBB"
Case 3
sec_name = "CCCC"
Case Else
MsgBox "選択してください"
Exit Function
End Select
strdate = Forms![outputHtml]![txt_date].Value
stropenargs = sec_name & "," & strdate
DoCmd.OpenReport rename, acViewPreview, , "期限 >= #" & strdate & "# AND " & sec_name & " = true", , stropenargs
End Function
