کد کامل فرم Main
Option Compare Database
Option Explicit
Private DataSources As New Collection
Private RecordsCount As Long
Private Sub Form_Close()
Set DataSources = Nothing
End Sub
Private Sub Form_Load()
Dim CountTables As Integer
Dim CountLinkedTables As Integer
Dim CountQueries As Integer
Dim i As Integer
Dim x As New Collection
Set x = GetTables
For i = 1 To x.count
DataSources.Add x.Item(i)
Me.LB_Sources.AddItem x.Item(i).SourceName & ";" & x.Item(i).SourceType
If x.Item(i).SourceType = "Table" Then
CountTables = CountTables + 1
Else
CountLinkedTables = CountLinkedTables + 1
End If
Next
Set x = GetQueries
For i = 1 To x.count
With x.Item(i)
If .Fields.count > 0 Then
DataSources.Add x.Item(i)
Me.LB_Sources.AddItem .SourceName & ";" & .SourceType
CountQueries = CountQueries + 1
End If
End With
Next
With Me.LB_Sources
If .ListCount > 1 Then
.Value = .ItemData(0)
LB_Sources_AfterUpdate
End If
End With
Me.LBL_Sources_Summary.Caption = _
"Tables=" & CountTables & _
" ; Linked Tables=" & CountLinkedTables & _
" ; Queries=" & CountQueries
End Sub
Private Sub LB_Sources_AfterUpdate()
Dim index As Integer
index = Me.LB_Sources.ListIndex
Me.LB_SelectedFields.RowSource = ""
With DataSources.Item(index + 1)
RecordsCount = DCount("*", .SourceName)
Me.LB_Fields.RowSource = .FieldsString
Me.LBL_Connect.Caption = .connect
Me.LBL_Fields_Summary.Caption = "Fields Count=" & .Fields.count & " , Records Count=" & RecordsCount
End With
Validate
End Sub
Private Sub BTN_None_Click()
Me.LB_SelectedFields.RowSource = ""
Validate
End Sub
Private Sub BTN_All_Click()
Me.LB_SelectedFields.RowSource = ""
Dim index As Integer
index = Me.LB_Sources.ListIndex
Dim i As Integer
Dim FieldsCount As Integer
With DataSources.Item(index + 1).Fields
FieldsCount = .count
For i = 1 To FieldsCount
If Not (.Item(i).FieldType Like "*Binary*" Or .Item(i).FieldType = "Attachment") Then
Me.LB_SelectedFields.AddItem .Item(i).FieldName
End If
Next
End With
Validate
End Sub
Private Sub BTN_Add_Click()
Dim SelectedField As String
Dim FieldType As String
Dim i As Integer
With Me.LB_Fields
If .ListIndex < 0 Then
.Value = .ItemData(0)
End If
SelectedField = .Value
FieldType = .Column(1)
If (FieldType Like "*Binary*" Or FieldType = "Attachment") Then
MsgBox "Attachment and Binary fields not allowed!", vbExclamation, "Invalid field type"
Exit Sub
End If
For i = 0 To .ListCount - 1
If Me.LB_SelectedFields.ItemData(i) = SelectedField Then Exit Sub
Next
Me.LB_SelectedFields.AddItem SelectedField
Me.LB_SelectedFields.Value = SelectedField
If .ListIndex < .ListCount - 1 Then
.Value = .ItemData(.ListIndex + 1)
End If
End With
Validate
End Sub
Private Sub BTN_Remove_Click()
Dim index As Integer
With Me.LB_SelectedFields
If .ListIndex < 0 Then
.Value = .ItemData(0)
End If
index = .ListIndex
.RemoveItem (index)
If index > .ListCount - 1 Then
index = .ListCount - 1
End If
.Value = .ItemData(index)
End With
Validate
End Sub
Private Sub BTN_Up_Click()
Dim index As Integer
With Me.LB_SelectedFields
index = .ListIndex
If index <= 0 Or .ListCount = 1 Then Exit Sub
Dim vlu As String
vlu = .Value
.RemoveItem (index)
.AddItem vlu, index - 1
.Value = vlu
End With
End Sub
Private Sub BTN_Down_Click()
Dim index As Integer
With Me.LB_SelectedFields
index = .ListIndex
If index = .ListCount - 1 Then Exit Sub
Dim vlu As String
vlu = .Value
.RemoveItem (index)
.AddItem vlu, index + 1
.Value = vlu
End With
End Sub
Private Sub Validate()
Me.BTN_Go.Enabled = (RecordsCount > 0 And Me.LB_SelectedFields.ListCount > 0)
End Sub
Private Sub BTN_Go_Click()
Dim fso As New FileSystemObject
Dim fl As TextStream
Dim rs As Recordset
Dim n As Long
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim Path As String
Dim PageSize As Integer
Dim PagesCount As Integer
Dim AnimationType As String
Dim SQL As String
AnimationType = Replace(Me.CB_AnimationType, " ", "")
Path = CurrentProject.Path + "\html"
PageSize = Me.CB_PageSize
Dim x As Variant
x = Split(Me.LB_SelectedFields.RowSource, ";")
For i = LBound(x) To UBound(x)
x(i) = "[" & x(i) & "]"
Next
SQL = "SELECT " & Join(x, ",") & " FROM [" & Me.LB_Sources & "]"
Set rs = CurrentDb.OpenRecordset(SQL, dbOpenDynaset, dbSeeChanges + dbReadOnly)
rs.MoveLast
rs.MoveFirst
n = rs.RecordCount
PagesCount = n / PageSize
If PagesCount > 100 Then
PagesCount = 100
' limit the page to a maximum of 100 to keep the html file at a reasonable size
ElseIf PagesCount * PageSize < n Then
PagesCount = PagesCount + 1
End If
If Not fso.FolderExists(Path) Then
fso.CreateFolder (Path)
End If
Set fl = fso.CreateTextFile( _
FileName:=Path + FileName, _
overwrite:=True, _
unicode:=True)
fl.write HTML_Start
m = 0
For i = 1 To PagesCount
If AnimationType = "None" Then
If i = 1 Then
fl.WriteLine "<div id='page_1' class='page visible'>"
Else
fl.WriteLine "<div id='page_" + Trim(i) + "' class='page hidden'>"
End If
Else
If i = 1 Then
fl.WriteLine "<div id='page_1' class='page visible " & AnimationType & "_in'>"
Else
fl.WriteLine "<div id='page_" + Trim(i) + "' class='page hidden " & AnimationType & "_out'>"
End If
End If
Select Case Me.CB_Theme
Case "Mixed"
Select Case i Mod 4
Case 0
fl.WriteLine "<table class='orange'>"
Case 1
fl.WriteLine "<table class='green'>"
Case 2
fl.WriteLine "<table class='blue'>"
Case 3
fl.WriteLine "<table class='black'>"
End Select
Case Else
fl.WriteLine "<table class='" & LCase(Me.CB_Theme) & "'>"
End Select
fl.write "<thead><tr>"
If Me.CHK_RowNumber Then
fl.write "<th>#</th>"
End If
For j = 1 To rs.Fields.count
fl.write "<th>" + rs.Fields(j - 1).Name + "</th>"
Next
fl.write "</tr>"
fl.WriteLine "</thead>"
fl.WriteLine "<tbody>"
For j = 1 To PageSize
If rs.EOF Then Exit For
If Me.CHK_RowNumber Then
m = m + 1
fl.write "<tr><td>" + Trim(m) + "</td>"
End If
For k = 1 To rs.Fields.count
If rs.Fields(k - 1).Type = dbBoolean Then
Select Case Me.CB_Booleans
Case "CheckBox"
If rs.Fields(k - 1).Value Then
fl.write "<td><input type='checkbox' checked></td>"
Else
fl.write "<td><input type='checkbox'></td>"
End If
Case "Toggle"
If rs.Fields(k - 1).Value Then
fl.write "<td><label class='switch'><input type='checkbox' checked><span class='slider'></span></label></td>"
Else
fl.write "<td><label class='switch'><input type='checkbox'><span class='slider'></span></label></td>"
End If
Case "Radio"
If rs.Fields(k - 1).Value Then
fl.write "<td><input type='radio' checked></td>"
Else
fl.write "<td><input type='radio'></td>"
End If
Case "Yes/No"
If rs.Fields(k - 1).Value Then
fl.write "<td>Yes</td>"
Else
fl.write "<td>No</td>"
End If
Case "On/Off"
If rs.Fields(k - 1).Value Then
fl.write "<td>On</td>"
Else
fl.write "<td>Off</td>"
End If
Case Else ' default True/False
fl.write "<td>" & rs.Fields(k - 1) & "</td>"
End Select
Else
fl.write "<td>" & rs.Fields(k - 1).Value & "</td>"
End If
Next
fl.WriteLine "</tr>"
rs.MoveNext
Next
fl.WriteLine "</tbody>"
fl.WriteLine "</table>"
fl.WriteLine "</div>"
DoEvents
Next
rs.Close
Set rs = Nothing
Dim xEnd As String
xEnd = Replace(HTML_End, "@PAGE_LIFE", 1000 * Me.CB_PageLife)
If AnimationType = "None" Then
xEnd = Replace(xEnd, "@ANIMATION_DURATION", "0s")
xEnd = Replace(xEnd, "@ANIMATION_TYPE_in", "")
xEnd = Replace(xEnd, "@ANIMATION_TYPE_out", "")
Else
xEnd = Replace(xEnd, "@ANIMATION_DURATION", Me.CB_AnimationDuration & "s")
xEnd = Replace(xEnd, "@ANIMATION_TYPE", AnimationType)
End If
fl.write xEnd
fl.Close
Set fso = Nothing
DoCmd.OpenForm "Browser"
End Sub
پاسخ با نقل قول
نوشته شده توسط mazoolagh
