www.pudn.com > kelon.rar > fShow.frm
VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form fShow
BackColor = &H00000000&
Caption = "KL生产进度显示 V1.01"
ClientHeight = 8100
ClientLeft = 165
ClientTop = 450
ClientWidth = 12765
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "fShow.frx":0000
LinkTopic = "Form3"
ScaleHeight = 8100
ScaleWidth = 12765
Begin VB.TextBox txtShow1
BackColor = &H00000000&
BorderStyle = 0 'None
ForeColor = &H00E0E0E0&
Height = 255
Index = 5
Left = 120
Locked = -1 'True
TabIndex = 10
TabStop = 0 'False
Text = "提示:"
Top = 7590
Width = 5280
End
Begin VB.TextBox txtShow1
Alignment = 2 'Center
BackColor = &H00000000&
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 4
Left = 8820
Locked = -1 'True
TabIndex = 9
TabStop = 0 'False
Top = 555
Width = 315
End
Begin VB.TextBox txtShow1
Alignment = 2 'Center
BackColor = &H00000000&
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 3
Left = 7380
Locked = -1 'True
TabIndex = 8
TabStop = 0 'False
Top = 555
Width = 1170
End
Begin VB.TextBox txtShow1
Alignment = 2 'Center
BackColor = &H00000000&
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 2
Left = 8940
Locked = -1 'True
TabIndex = 7
TabStop = 0 'False
Top = 120
Width = 315
End
Begin VB.TextBox txtShow1
Alignment = 2 'Center
BackColor = &H00000000&
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 1
Left = 8340
Locked = -1 'True
TabIndex = 6
TabStop = 0 'False
Top = 180
Width = 315
End
Begin VB.TextBox txtShow1
Alignment = 2 'Center
BackColor = &H00000000&
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 255
Index = 0
Left = 7485
Locked = -1 'True
TabIndex = 5
TabStop = 0 'False
Top = 180
Width = 600
End
Begin RichTextLib.RichTextBox labTitle2
Height = 585
Left = 1440
TabIndex = 4
TabStop = 0 'False
Top = 75
Width = 5610
_ExtentX = 9895
_ExtentY = 1032
_Version = 393217
BackColor = 12632256
BorderStyle = 0
Enabled = -1 'True
ReadOnly = -1 'True
Appearance = 0
TextRTF = $"fShow.frx":0442
End
Begin VB.PictureBox Picture1
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H0000C0C0&
BorderStyle = 0 'None
FillColor = &H0000FFFF&
ForeColor = &H0000FFFF&
Height = 15
Left = -75
ScaleHeight = 15
ScaleWidth = 15435
TabIndex = 3
Top = 765
Width = 15435
End
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 500
Left = 60
Top = 150
End
Begin RichTextLib.RichTextBox labTitle1
Height = 1455
Left = 0
TabIndex = 1
TabStop = 0 'False
Top = 15
Width = 15150
_ExtentX = 26723
_ExtentY = 2566
_Version = 393217
BackColor = 14737632
BorderStyle = 0
HideSelection = 0 'False
ReadOnly = -1 'True
Appearance = 0
TextRTF = $"fShow.frx":04CF
End
Begin VB.TextBox Text1
Height = 360
Left = 3870
TabIndex = 2
Text = "Text1"
Top = 450
Width = 330
End
Begin VB.Label Label2
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "01"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 240
Index = 0
Left = 285
TabIndex = 11
Top = 2115
Visible = 0 'False
Width = 405
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
BackStyle = 0 'Transparent
Caption = "------"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 390
Index = 0
Left = 645
TabIndex = 0
Top = 2220
Width = 1110
End
Begin VB.Menu menu
Caption = "menu"
Visible = 0 'False
Begin VB.Menu menu1
Caption = "刷新数据"
Index = 1
Begin VB.Menu m01
Caption = "允许刷新"
Index = 1
End
Begin VB.Menu m01
Caption = "禁止刷新"
Index = 2
End
End
Begin VB.Menu menu1
Caption = "界面设置"
Index = 2
Begin VB.Menu m02
Caption = "充许调整"
Index = 1
End
Begin VB.Menu m02
Caption = "界面属性"
Index = 2
End
End
Begin VB.Menu menu1
Caption = "控制面板"
Index = 3
Begin VB.Menu m03
Caption = "打开"
Index = 1
End
Begin VB.Menu m03
Caption = "关闭"
Index = 2
End
End
End
End
Attribute VB_Name = "fShow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const LocFileName = "\res\lz_kl_show.ini"
Dim sSql As String
Dim nrs As New ADODB.Recordset
Dim timer_interval As Long
Dim isfirstshow As Boolean
'位置: 3,4,5
'位置: 6,7,8,9,10,11
Private Sub Form_Load()
If App.PrevInstance Then
If App.Title = Me.Caption Then
' MsgBox ("注意：程序已经运行，不能再次装载。"), vbExclamation
End
End If
End If
IsAdjust = False
isfirstshow = True
Call GetIniFileName
Call OpenODBC(Cn_Des, "ConnectionString001") '打开数据库
Call SetFrmBackGrand
Call GetDbDate '取得数据数目
Call SetCoverOcx(True) '设置界面
Call SetRefTime '设置刷新时间
Call SetobjLoc(Me, 3)
Call SetobjLoc(labTitle2, 4)
Call SetobjLoc(Picture1, 5)
Dim I As Long
For I = 0 To 5
Call SetobjLoc(txtShow1(I), I + 6)
Next
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
Me.PopupMenu menu
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call SaveobjLoc(Me, 3)
Call SaveobjLoc(labTitle2, 4)
Call SaveobjLoc(Picture1, 5)
Dim I As Long
For I = 0 To 5
Call SaveobjLoc(txtShow1(I), I + 6)
Next
End Sub
Private Sub Label1_DblClick(Index As Integer)
With myLabel
.CurrCol = Index Mod .Cols + 1
'.colDist = Label1(1).Left - Label1(0).Left
.RowWidth = Label1(.Cols).Top - Label1(0).Top '行间距, 单一值
.Left = Label1(.CurrCol - 1).Left
.Top = Label1(.CurrCol - 1).Top
.Width = Label1(.CurrCol - 1).Width
.Height = Label1(0).Height '行高, 单一值
End With
fShowSet.Show 1
End Sub
Public Sub GetDbDate()
Dim nCount As Long
sSql = mod01.pGetString(App.Path + LocFileName, "access", "sqlselectcount")
nrs.Open sSql, Cn_Des, , , adCmdText
myLabel.Rows = nrs.Fields(0).Value
nrs.Close
sSql = mod01.pGetString(App.Path + LocFileName, "access", "sqlselect")
'安全性:
If InStr(sSql, "delete") > 0 Or InStr(sSql, "update") > 0 Then
MsgBox "非法SQL语句"
End
Exit Sub
End If
nrs.Open sSql, Cn_Des, , , adCmdText
myLabel.Cols = nrs.Fields.Count
End Sub
'Public Sub ShowdbData()
' Dim i As Long
' Dim j As Long
' Dim c As Long: c = 0
' nrs.MoveFirst
' For i = 0 To myLabel.Rows - 1
' For j = 0 To myLabel.Cols - 1
' Label1(c).Caption = nrs.Fields(j).Value
' Label1(c).Visible = True
' c = c + 1
' Next
' nrs.MoveNext
' Next
' nrs.Close
'End Sub
Public Function ShowDBData(ByVal bisstart As Boolean) As Long
Dim I As Long, j As Long
Dim c As Long: c = 0
Dim t As Long: t = 0
Dim s As String
If Not bisstart Then
nrs.Open sSql, Cn_Des, , , adCmdText
End If
nrs.MoveFirst
For I = 0 To myLabel.Rows - 1
For j = 0 To myLabel.Cols - 1
s = nrs.Fields(j).Value
If s <> Label1(c).Caption Then
Label1(c).Caption = nrs.Fields(j).Value
t = t + 1
End If
Label1(c).Visible = True
c = c + 1
Next
nrs.MoveNext
Next
nrs.Close
ShowDBData = t
End Function
Private Sub labTitle1_GotFocus()
Text1.SetFocus
End Sub
Private Sub labTitle2_GotFocus()
Text1.SetFocus
End Sub
Private Sub labTitle2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call DragForm(Button, labTitle2)
End Sub
Private Sub m01_Click(Index As Integer)
Select Case Index
Case 1
If isfirstshow Then
Call ShowDBData(True) '显示数据
isfirstshow = False
End If
Timer1.Enabled = True
Dim I As Long
On Error Resume Next
For I = 0 To 19
If I = 0 Then
Label2(0).Left = Label2(0).Width / 2
Else
Load Label2(I)
Label2(I).Left = Label2(0).Left
End If
Label2(I).FontSize = Label1(I).FontSize
Label2(I).Top = Label1(I * myLabel.Cols).Top
Label2(I).Caption = Format(I + 1, "00")
Label2(I).Visible = True
Next
On Error GoTo 0
Case 2
Timer1.Enabled = False
End Select
End Sub
Private Sub m02_Click(Index As Integer)
Select Case Index
Case 1
IsAdjust = Not IsAdjust
m02(Index).Checked = IsAdjust
Call SetCoverOcx(False)
Case 2
With myLabel
.CurrCol = Index Mod .Cols + 1
'.colDist = Label1(1).Left - Label1(0).Left
.RowWidth = Label1(.Cols).Top - Label1(0).Top '行间距, 单一值
.Left = Label1(.CurrCol - 1).Left
.Top = Label1(.CurrCol - 1).Top
.Width = Label1(.CurrCol - 1).Width
.Height = Label1(0).Height '行高, 单一值
End With
fShowSet.Show 1
End Select
End Sub
Private Sub m03_Click(Index As Integer)
Select Case Index
Case 1
m03(1).Checked = True
m03(2).Checked = False
fControl.Show
Case 2
m03(2).Checked = True
m03(1).Checked = False
Unload fControl
End Select
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call DragForm(Button, Picture1)
End Sub
Private Sub Timer1_Timer()
Static c As Long
Dim ls As String
ls = Format(Date, "YYYY")
If ls <> txtShow1(0).Text Then txtShow1(0).Text = ls
ls = Format(Date, "MM")
If ls <> txtShow1(1).Text Then txtShow1(1).Text = ls
ls = Format(Date, "DD")
If ls <> txtShow1(2).Text Then txtShow1(2).Text = ls
ls = Format(Time(), "HH:MM:SS")
If ls <> txtShow1(3).Text Then txtShow1(3).Text = ls
ls = Format(23, "00")
If ls <> txtShow1(4).Text Then txtShow1(4).Text = ls
c = c + 1
If (c Mod timer_interval) = 0 Then
c = 0
txtShow1(5).Text = "刷新时间: " & Format(Now, "hh:mm:ss") & _
" 数据: " & ShowDBData(False) & " 个"
End If
End Sub
Private Sub SetRefTime()
Dim ss As Long
ss = Val(mod01.pGetString(App.Path + LocFileName, "timer", "timer1"))
If ss < 2 Then ss = 5 ' 不能小于2秒
If ss > 15 Then ss = 10 '不能大于15秒
timer_interval = Val(ss)
End Sub
Public Sub SetCoverOcx(ByVal bisstart As Boolean)
Dim nrows As Long, ncols As Long
Dim arry As Variant
Dim ss As String
ss = mod01.pGetString(App.Path + LocFileName, "ShowSet", "Showsta")
arry = Split(ss, ",")
myLabel.RowWidth = Val(arry(0)) '取行间距
myLabel.Height = IIf(Val(arry(1)) > 0, Val(arry(1)), Label1(0).Height) '取高
For nrows = 0 To myLabel.Rows - 1
For ncols = 0 To myLabel.Cols - 1
If nrows = 0 Then '列间距/行间距/左/上/宽/高
ss = mod01.pGetString(App.Path + LocFileName, "ShowSet", "ShowLoc" + Format(ncols + 1, "00"))
arry = Split(ss, ",")
End If
' Debug.Print (ncols + nrows * myLabel.Cols)
If ncols + nrows * myLabel.Cols = 0 Then '考虑第一标签
With myLabel
.Left = IIf(Val(arry(2)) > 0, Val(arry(2)), Label1(0).Left)
.Top = IIf(Val(arry(3)) > 0, Val(arry(3)), Label1(0).Top)
.Width = IIf(Val(arry(4)) > 0, Val(arry(4)), Label1(0).Width)
Label1(0).Move .Left, .Top, .Width, .Height
If arry(6) <> "" And arry(6) <> "?" Then Label1(0).FontName = arry(6)
If Val(arry(7)) > 0 Then Label1(0).FontSize = Val(arry(7))
End With
Else
If bisstart Then
Load Label1(ncols + nrows * myLabel.Cols)
End If
With Label1(ncols + nrows * myLabel.Cols)
If nrows = 0 Then ''考虑第一行标签 top height 相同
With myLabel
.colDist = IIf(Val(arry(0)) > 0, Val(arry(0)), Label1(ncols - 1).Width)
.Left = IIf(Val(arry(2)) > 0, Val(arry(2)), Label1(ncols - 1).Left + .colDist)
.Width = IIf(Val(arry(4)) > 0, Val(arry(4)), Label1(0).Width)
End With
.Move myLabel.Left, Label1(0).Top, myLabel.Width, Label1(0).Height
If arry(6) <> "" And arry(6) <> "?" Then .FontName = arry(6)
If Val(arry(7)) > 0 Then .FontSize = Val(arry(7))
Else
If ncols = 0 Then ''考虑第一列标签
myLabel.RowWidth = IIf(myLabel.RowWidth > 0, myLabel.RowWidth, _
Label1(ncols + (nrows - 1) * myLabel.Cols).Height)
.Move Label1(0).Left, _
Label1(ncols + (nrows - 1) * myLabel.Cols).Top + myLabel.RowWidth, _
Label1(0).Width, _
Label1(0).Height
Else
.Move Label1(ncols).Left, _
Label1(ncols + nrows * myLabel.Cols - 1).Top, _
Label1(ncols).Width, _
Label1(0).Height
.FontName = Label1(ncols).FontName
.FontSize = Label1(ncols).FontSize
End If
End If
End With
End If
Next
Next
End Sub
Private Sub SetFrmBackGrand()
Dim ss As String
ss = ""
ss = pGetString(App.Path + LocFileName, "ShowSet", Me.Name)
labTitle1.Move 0, 0
labTitle1.BackColor = &H0&
labTitle2.BackColor = &H0&
labTitle1.FILENAME = App.Path + "\res\" + ss + "01.rtf"
labTitle2.FILENAME = App.Path + "\res\" + ss + "02.rtf"
' Me.Picture = LoadPicture(App.Path + "\res\" + ss)
End Sub
Private Sub txtShow1_GotFocus(Index As Integer)
Text1.SetFocus
End Sub
Private Sub txtShow1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call DragForm(Button, txtShow1(Index))
End Sub