frmtohtm.frm

银行定储模拟程序

VERSION 5.00
Begin VB.Form frmToHtm 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "表格设置"
   ClientHeight    =   2835
   ClientLeft      =   30
   ClientTop       =   330
   ClientWidth     =   5295
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2835
   ScaleWidth      =   5295
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame2 
      Caption         =   "打印设置"
      Height          =   2775
      Left            =   2640
      TabIndex        =   2
      Top             =   0
      Width           =   2535
      Begin VB.CommandButton Command1 
         Caption         =   "取消(&C)"
         Height          =   375
         Left            =   1320
         TabIndex        =   11
         Top             =   2280
         Width           =   1095
      End
      Begin VB.TextBox Text1 
         Height          =   270
         Left            =   120
         TabIndex        =   7
         Top             =   480
         Width           =   2295
      End
      Begin VB.CommandButton ok 
         Caption         =   "输出(&O)"
         Height          =   375
         Left            =   120
         TabIndex        =   6
         Top             =   2280
         Width           =   1095
      End
      Begin VB.TextBox Text2 
         ForeColor       =   &H00000000&
         Height          =   270
         Left            =   120
         TabIndex        =   5
         Top             =   1080
         Width           =   2295
      End
      Begin VB.TextBox Text3 
         Height          =   270
         Left            =   1680
         TabIndex        =   4
         Top             =   1440
         Width           =   735
      End
      Begin VB.CheckBox option1 
         Caption         =   "设置为超链接"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   255
         Left            =   120
         TabIndex        =   3
         Top             =   1920
         Width           =   1695
      End
      Begin VB.Label Label2 
         BackStyle       =   0  'Transparent
         Caption         =   "编辑列标题"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   255
         Left            =   120
         TabIndex        =   10
         Top             =   240
         Width           =   1335
      End
      Begin VB.Label Label3 
         BackStyle       =   0  'Transparent
         Caption         =   "表格标题"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   255
         Left            =   120
         TabIndex        =   9
         Top             =   840
         Width           =   855
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "每个表格的行数："
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   10.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   210
         Left            =   120
         TabIndex        =   8
         Top             =   1440
         Width           =   1680
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "请选择要打印的列"
      Height          =   2775
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   2535
      Begin VB.ListBox List1 
         ForeColor       =   &H00000000&
         Height          =   2370
         Left            =   120
         Style           =   1  'Checkbox
         TabIndex        =   1
         Top             =   240
         Width           =   2295
      End
   End
End
Attribute VB_Name = "frmToHtm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim db As Database
Dim rs As Recordset, ll() As Boolean
Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Load()
Text2 = PrintName
Dim i As Integer, dd As String
On Error GoTo er
Set db = OpenDatabase(App.Path & "\bank.mdb")
Set rs = db.OpenRecordset(PrintName, dbOpenDynaset)
ReDim ll(rs.Fields.Count - 1)
List1.Clear

rs.MoveFirst
For i = 0 To rs.Fields.Count - 1
List1.AddItem rs.Fields(i).Name
List1.Selected(i) = True
If rs.Fields(i).Name = "密码" Or rs.Fields(i).Name = "营业员" Or rs.Fields(i).Name = "工号" Then List1.Selected(i) = False
dd = List1.List(i)
If rs.Fields(dd).Type = 10 Then
If LCase(Left(rs.Fields(dd).Value, 7)) = "http://" Then
ll(i) = True
Else
ll(i) = False
End If
End If
Next
rs.MoveLast
Text3 = rs.RecordCount
db.Close
Exit Sub
er:
MsgBox Err.Description, vbCritical, "出错："
Unload Me
End Sub


Private Sub List1_Click()
Dim dd As String
If List1.Selected(List1.ListIndex) Then
dd = List1.List(List1.ListIndex)
Text1 = dd
Text1.Enabled = True
option1.Enabled = True
option1.Value = IIf(ll(List1.ListIndex), vbChecked, Unchecked)
Else
Text1 = List1.List(List1.ListIndex)
option1.Enabled = False
Text1.Enabled = False
End If
If List1.List(List1.ListIndex) = "密码" Or List1.List(List1.ListIndex) = "营业员" Or List1.List(List1.ListIndex) = "工号" Then
List1.Selected(List1.ListIndex) = False
End If
End Sub

Private Sub ok_Click()
Dim FName, PicName As String
Dim n As Long
FName = Environ("temp") & "\printtmp.htm"
PicName = Environ("temp") & "\backgrd.jpg"
If Dir(App.Path & "\backgrd.jpg") <> "" Then FileCopy App.Path & "\backgrd.jpg", PicName
If Dir(FName) <> "" Then Kill FName
Open FName For Output As #1
Set db = OpenDatabase(App.Path & "\bank.mdb")
Set rs = db.OpenRecordset(PrintName, dbOpenDynaset)
If List1.SelCount > 0 Then
Dim htmls As String
Print #1, "<html>"
Print #1, "<head>"
Print #1, "<title>" & Text2 & "</title>"
Print #1, "<meta http-equiv='Content-Type' content='text/html; charset=gb2312'>"
Print #1, "</head>"
If Dir(PicName) <> "" Then
Print #1, "<body background=backgrd.jpg>"
Else
Print #1, "<body>"
End If
rs.MoveFirst
n = 0
While rs.EOF = False
Print #1, "<table border=1 align=center style=""border-collapse: collapse"" bordercolor=""#111111"" width=""100%"">"
Print #1, "<caption>" & Text2 & "</caption>"
Fsum = List1.ListCount - 1
For i = 0 To Fsum
If List1.Selected(i) Then
Print #1, "<th><font size=2>" & List1.List(i) & "</font></th>"
End If
Next
Dim bb As Long, ca As String, values As String
bb = 1
For n = 1 To Val(Text3)
Print #1, "<tr>"
For i = 0 To Fsum
If List1.Selected(i) Then
If ll(i) Then
values = "<td><a href='" & rs.Fields(i).Value & "'>" & rs.Fields(i).Value
values = values & "</a></td>"
Else
values = "<td><font size=2>" & rs.Fields(i).Value & "</font></td>"
End If
Print #1, values
End If
Next i
rs.MoveNext
If rs.EOF Then
Exit For
End If
Next n
Print #1, "</table>"
Wend
Print #1, "</body>"
Print #1, "</html>"
End If
Close #1
ShellExecute 0, vbNullString, FName, vbNullString, vbNullString, vbMaximizedFocus
Unload Me
Exit Sub

End Sub

Private Sub Option1_Click()
ll(List1.ListIndex) = (option1.Value = vbChecked)
End Sub

Private Sub Text1_Change()
Dim lens As Integer
List1.List(List1.ListIndex) = Text1
lens = Len(Trim(CStr(Text2)))
If lens > 50 Then Text1 = Left(CStr(Text2), 50)
End Sub

Private Sub Text2_Change()
If Len(Trim(CStr(Text2))) > 30 Then Text2 = Left(CStr(Text2), 30)
End Sub

Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 8 Then Exit Sub
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub

Private Sub Text3_LostFocus()
If IsNumeric(Text3) = False Then
MsgBox "输入行数错误!"
Text3.SetFocus
End If
If Val(Text3) < 1 Then Text3 = 1
End Sub