📄 frmsetpage.frm
字号:
Top = 1920
Width = 2415
End
Begin VB.CommandButton cmdClose
Cancel = -1 'True
Caption = "退出(&C)"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 330
Left = 6435
TabIndex = 0
Top = 4380
Width = 1230
End
Begin VB.Frame Frame2
Caption = "页头打印区域设置："
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1575
Index = 0
Left = 360
TabIndex = 4
Top = 120
Width = 7335
Begin MSComctlLib.ListView lvwLine
Height = 1215
Index = 0
Left = 1320
TabIndex = 12
Top = 240
Width = 2535
_ExtentX = 4471
_ExtentY = 2143
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 2
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "行号"
Object.Width = 882
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "高度（mm）"
Object.Width = 2999
EndProperty
End
End
Begin VB.Frame Frame2
Caption = "页尾打印区域设置："
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1575
Index = 1
Left = 360
TabIndex = 15
Top = 120
Width = 7335
Begin MSComctlLib.ListView lvwLine
Height = 1215
Index = 1
Left = 1320
TabIndex = 16
Top = 240
Width = 2535
_ExtentX = 4471
_ExtentY = 2143
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = -1 'True
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 2
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "行号"
Object.Width = 882
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "高度（mm）"
Object.Width = 2999
EndProperty
End
End
Begin VB.Label page
AutoSize = -1 'True
Height = 195
Left = 300
TabIndex = 1
Top = 4455
Width = 45
End
End
Attribute VB_Name = "frmQuerySetPage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub cboBand_Click()
Dim i, iLineCount As Integer
cboNum.Clear
If cboBand.Text = "页头" Then
iLineCount = lvwLine(0).ListItems.Count
For i = 1 To iLineCount
cboNum.AddItem "第 " & lvwLine(0).ListItems(i).Text & " 行"
cboNum.ItemData(cboNum.NewIndex) = CInt(lvwLine(0).ListItems(i).SubItems(1))
Next i
Else
iLineCount = lvwLine(1).ListItems.Count
For i = 1 To iLineCount
cboNum.AddItem "第 " & lvwLine(1).ListItems(i).Text & " 行"
cboNum.ItemData(cboNum.NewIndex) = CInt(lvwLine(1).ListItems(i).SubItems(1))
Next i
End If
End Sub
Private Sub cmdBand_Click(Index As Integer)
Dim itemReturn As ListItem
Select Case Index
Case 0
If txtHeight <> "" Then
If optBand(0).Value Then
Set itemReturn = lvwLine(0).ListItems.Add(, , CStr(lvwLine(0).ListItems.Count + 1))
Else
Set itemReturn = lvwLine(1).ListItems.Add(, , CStr(lvwLine(1).ListItems.Count + 1))
End If
itemReturn.SubItems(1) = txtHeight
End If
Case 1
If txtHeight <> "" Then
If optBand(0).Value Then
lvwLine(0).ListItems(lvwLine(0).SelectedItem.Index).SubItems(1) = Trim(txtHeight)
Else
lvwLine(1).ListItems(lvwLine(1).SelectedItem.Index).SubItems(1) = Trim(txtHeight)
End If
End If
Case 2
txtHeight = ""
If optBand(0).Value Then
If lvwLine(0).ListItems.Count >= 0 Then lvwLine(0).ListItems.Remove lvwLine(0).ListItems.Count
Else
If lvwLine(1).ListItems.Count >= 0 Then lvwLine(1).ListItems.Remove lvwLine(1).ListItems.Count
End If
End Select
End Sub
Private Sub cmdClose_Click()
Dim i As Integer, iHL As Integer, iFL As Integer
Dim clHead As New Collection '页头每行的起始高度
Dim clFoot As New Collection '页尾每行的起始高度
On Error GoTo ErrorHandle
iHeadHeight = 0: iFootHeight = 0
iHL = lvwLine(0).ListItems.Count
For i = 1 To iHL
iHeadHeight = iHeadHeight + CInt(lvwLine(0).ListItems(i).SubItems(1))
If i = 1 Then
clHead.Add 0
Else
clHead.Add clHead.Item(i - 1) + CInt(lvwLine(0).ListItems(i - 1).SubItems(1))
End If
Next i
iFL = lvwLine(1).ListItems.Count
For i = 1 To iFL
iFootHeight = iFootHeight + CInt(lvwLine(1).ListItems(i).SubItems(1))
If i = 1 Then
clFoot.Add 0
Else
clFoot.Add clFoot.Item(i - 1) + CInt(lvwLine(1).ListItems(i - 1).SubItems(1))
End If
Next i
For i = 0 To iCount - 1
If liPrint(i).band = "head" Then
If liPrint(i).LineNum > iHL Then
MsgBox "｛" & liPrint(i).Name & "｝中的行号已经不存在，请检查！ ", , MSGTEXT
Exit Sub
Else
liPrint(i).Height = CInt(lvwLine(0).ListItems(liPrint(i).LineNum).SubItems(1))
liPrint(i).curY = clHead.Item(liPrint(i).LineNum)
End If
Else
If liPrint(i).LineNum > iFL Then
MsgBox "｛" & liPrint(i).Name & "｝中的行号已经不存在，请检查！ ", , MSGTEXT
Exit Sub
Else
liPrint(i).Height = CInt(lvwLine(1).ListItems(liPrint(i).LineNum).SubItems(1))
liPrint(i).curY = clFoot.Item(liPrint(i).LineNum)
End If
End If
Next i
Unload Me
Exit Sub
ErrorHandle:
MsgBox "保存设置失败,请检查后再试！", , MSGTEXT
End Sub
Private Sub cmdDlg_Click()
dlg.Flags = cdlCFBoth + cdlCFEffects
dlg.CancelError = True
Call CopyFontColor(txtFont, dlg, True)
On Error GoTo Errhandle:
dlg.ShowFont
Call CopyFontColor(txtFont, dlg, False)
txtFont = txtFont.Font.Name
Errhandle:
End Sub
Private Sub CopyFontColor(txt As TextBox, dlg As CommonDialog, Optional todlg As Boolean = True)
'/*拷贝字体和颜色,todlg=true则是传到字体对话框，否则是从对话框得到
If todlg Then
With dlg
.FontName = txt.Font.Name
.FontSize = txt.Font.Size
.FontBold = txt.Font.Bold
.FontItalic = txt.Font.Italic
.FontStrikethru = txt.Font.Strikethrough
.FontUnderline = txt.Font.Underline
.Color = txt.ForeColor
End With
Else
With txt
.Font.Name = dlg.FontName
.Font.Size = dlg.FontSize
.Font.Bold = dlg.FontBold
.Font.Italic = dlg.FontItalic
.Font.Strikethrough = dlg.FontStrikethru
.Font.Underline = dlg.FontUnderline
.ForeColor = dlg.Color
End With
End If
End Sub
Private Sub cmdSave_Click()
Call SetliPrintInfo(liPrint, lstLabel.ListIndex, IIf(cboBand.ListIndex = 0, "head", "foot"), _
0, cboNum.ItemData(cboNum.ListIndex), cboAlign.ListIndex + 1, _
cboNum.ListIndex + 1, lstLabel.Text, txtText, txtFont.Font, txtFont.ForeColor)
End Sub
Private Sub Form_Load()
Dim i As Integer
Dim iHL As Integer, iFL As Integer '页头、页尾的行数
Dim itemFind As ListItem
optBand(0).Value = True
Frame2(0).Visible = True
Frame2(1).Visible = False
iHL = 0: iFL = 0
For i = 0 To iCount - 1
lstLabel.AddItem liPrint(i).Name
If (liPrint(i).band = "head") And (liPrint(i).LineNum > iHL) Then iHL = liPrint(i).LineNum
If (liPrint(i).band = "foot") And (liPrint(i).LineNum > iFL) Then iFL = liPrint(i).LineNum
Next i
For i = 1 To iHL
lvwLine(0).ListItems.Add , , CStr(i)
Next i
For i = 1 To iFL
lvwLine(1).ListItems.Add , , CStr(i)
Next i
For i = 0 To iCount - 1
If (liPrint(i).band = "head") Then
Set itemFind = lvwLine(0).FindItem(CStr(liPrint(i).LineNum))
If Not (itemFind Is Nothing) Then itemFind.SubItems(1) = CStr(liPrint(i).Height)
Else
Set itemFind = lvwLine(1).FindItem(CStr(liPrint(i).LineNum))
If Not (itemFind Is Nothing) Then itemFind.SubItems(1) = CStr(liPrint(i).Height)
End If
Next i
End Sub
Private Sub lstLabel_Click()
txtText = liPrint(lstLabel.ListIndex).Text
Call CopyFont(liPrint(lstLabel.ListIndex).Font, txtFont.Font)
txtFont = liPrint(lstLabel.ListIndex).Font.Name
txtFont.ForeColor = liPrint(lstLabel.ListIndex).ForeColor
cboBand.ListIndex = IIf(liPrint(lstLabel.ListIndex).band = "head", 0, 1)
If liPrint(lstLabel.ListIndex).LineNum <= cboNum.ListCount Then
cboNum.ListIndex = CStr(liPrint(lstLabel.ListIndex).LineNum - 1)
Else
MsgBox "当前文本的所在行不存在，可能已经被删除！", , MSGTEXT
cboNum.ListIndex = cboNum.ListCount - 1
End If
cboAlign.ListIndex = liPrint(lstLabel.ListIndex).LineAlign - 1
End Sub
Private Sub lvwLine_ItemClick(Index As Integer, ByVal Item As MSComctlLib.ListItem)
txtHeight.Text = Item.SubItems(1)
End Sub
Private Sub optBand_Click(Index As Integer)
If optBand(0).Value Then
Frame2(0).Visible = True
Frame2(1).Visible = False
Else
Frame2(0).Visible = False
Frame2(1).Visible = True
End If
End Sub
Private Sub txtHeight_KeyPress(KeyAscii As Integer)
If (Chr(KeyAscii) < "0" Or Chr(KeyAscii) > "9") And KeyAscii <> 8 Then KeyAscii = 0
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -