📄 frmreport.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmReport
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
Caption = "打印或保存报表"
ClientHeight = 5085
ClientLeft = 45
ClientTop = 330
ClientWidth = 8985
ForeColor = &H00FFFFFF&
LinkTopic = "Form4"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5085
ScaleWidth = 8985
StartUpPosition = 1 '所有者中心
Begin Add_Remove_Platinum_2004.CommandButton CmdClose
Height = 495
Left = 7200
TabIndex = 7
Top = 4440
Width = 1695
_ExtentX = 2990
_ExtentY = 873
Caption = "关闭"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Add_Remove_Platinum_2004.CommandButton CmdSave
Height = 495
Left = 3720
TabIndex = 6
Top = 4440
Width = 1695
_ExtentX = 2990
_ExtentY = 873
Caption = "保存"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Add_Remove_Platinum_2004.CommandButton CmdPrint
Height = 495
Left = 120
TabIndex = 5
Top = 4440
Width = 1695
_ExtentX = 2990
_ExtentY = 873
Caption = "打印"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.TextBox txtPrint
Appearance = 0 'Flat
BeginProperty Font
Name = "Lucida Console"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1455
Left = 360
MultiLine = -1 'True
TabIndex = 4
Top = 1080
Visible = 0 'False
Width = 8055
End
Begin VB.TextBox txtHeader
Appearance = 0 'Flat
BeginProperty Font
Name = "Lucida Console"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2175
Left = 240
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 2
Top = 840
Width = 8535
End
Begin VB.OptionButton OptDetailInfo
BackColor = &H00FFFFFF&
Caption = "长格式 (程序名, 大小和卸载命令)"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 240
TabIndex = 1
Top = 3720
Width = 7455
End
Begin VB.OptionButton OptDName
BackColor = &H00FFFFFF&
Caption = "短格式 (仅程序名称)"
BeginProperty Font
Name = "宋体"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
Left = 240
TabIndex = 0
Top = 3240
Width = 5895
End
Begin MSComDlg.CommonDialog cmdlgFile
Left = 5880
Top = 4440
_ExtentX = 847
_ExtentY = 847
_Version = 393216
DialogTitle = "请选择一个保存文件"
Filter = "(Text Files) *.txt |*.txt"
End
Begin VB.Line Line1
Index = 1
X1 = 8880
X2 = 8880
Y1 = 480
Y2 = 4200
End
Begin VB.Line Line2
X1 = 120
X2 = 8880
Y1 = 4200
Y2 = 4200
End
Begin VB.Line Line1
Index = 0
X1 = 120
X2 = 120
Y1 = 480
Y2 = 4200
End
Begin VB.Label Label1
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "报表标题 (添加, 改变或者删除文字 )"
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 2985
TabIndex = 3
Top = 285
Width = 2955
End
Begin VB.Shape Shape2
FillColor = &H00E0E0E0&
FillStyle = 0 'Solid
Height = 615
Index = 1
Left = 120
Shape = 4 'Rounded Rectangle
Top = 120
Width = 8775
End
End
Attribute VB_Name = "FrmReport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'★★★★★****************************★★★★★**********************★★★★★
'金诺VB园-收藏整理
'本站是专注于VB和VBNET编程的源码下载站
'发布日期：2008-3-14 22:00:47
'网 站：http://www.vbget.com/ (金诺VB园)
'网 站：http://www.vbget.com/daohan/ (VB编程网址导航)
'E-Mail ：vbget@yahoo.cn
'QQ ：158676144
'源码作者：如果您有VB商业源码需要获得收益，本站将有VIP收费下载频道可供你发布!
' 您有权定价;改价;删除;及即时查看下载量(即收益)，所有收益全部归您！
' 本站将在双方协商的一个金额周期内打款到作者帐户中，您只需负责打款费用！
' 本站只作为一个平台提供最新VB源码咨讯和源码下载！
'本注释由<站长工具之智能注释>软件自动添加！金诺VB园有此软件下载！
'★★★★★****************************★★★★★**********************★★★★★
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Const EM_FMTLINES = &HC8
'To show the Computer and User name in log
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'=========================================================================
' Close window
'=========================================================================
Private Sub cmdClose_Click()
Unload Me
End Sub
' To print the report on printer
' First save the data to temp file
' reload it in text box
' Format the text box data so that long lines could be wrapped
' Delete the temp file
Private Sub cmdPrint_Click()
On Error Resume Next
Dim intFile As Integer
cmdlgFile.CancelError = True
' Show the printer dialog to user
cmdlgFile.ShowPrinter
If Err Then
Exit Sub
End If
' Save the file
saveFile App.Path & "\ReportTemp.txt"
intFile = FreeFile
If LenB(Dir$(App.Path & "\ReportTemp.txt")) <> 0 Then
Open App.Path & "\ReportTemp.txt" For Input As #intFile
If LOF(intFile) > 0 Then
txtPrint.Text = Input(LOF(intFile), intFile)
Close intFile
' Print the file
printFile
Kill App.Path & "\ReportTemp.txt"
Else
MsgBox "No data to print.", vbInformation, App.Title
Close intFile
Kill App.Path & "\ReportTemp.txt"
End If
End If
End Sub
Private Sub cmdSave_Click()
On Error Resume Next
cmdlgFile.CancelError = True
cmdlgFile.Filter = "Text File (*.txt)|*.txt"
cmdlgFile.Flags = cdlOFNOverwritePrompt
cmdlgFile.ShowSave
If Err Then
Exit Sub
End If
saveFile cmdlgFile.filename
End Sub
'=========================================================================
' When the form loads
' - set the default icon's property
' - find computer name and use name
' - Generate a default header message and leave it editable
'=========================================================================
Private Sub Form_Load()
Dim computer_name As String, iUserName As String
Me.Icon = FrmMain.Icon
OptDName.Value = True
computer_name = Space$(256)
GetComputerName computer_name, Len(computer_name)
computer_name = Left$(computer_name, InStr(1, computer_name, Chr$(0)))
iUserName = Space$(256)
GetUserName iUserName, Len(iUserName)
iUserName = Left$(iUserName, InStr(1, iUserName, Chr$(0)))
txtHeader = "Software Audit Report for: " & computer_name
txtHeader = txtHeader & vbNewLine
txtHeader = txtHeader & "Generated On : " & Date & vbNewLine
txtHeader = txtHeader & vbNewLine
txtHeader = txtHeader & "Generated By : " & App.ProductName & vbNewLine
txtHeader = txtHeader & vbNewLine
txtHeader = txtHeader & "Computer Name : " & computer_name
txtHeader = txtHeader & vbNewLine
txtHeader = txtHeader & "User Name : " & iUserName
txtHeader = txtHeader & vbNewLine
txtHeader = txtHeader & "Operating System : " & gstrOS
txtHeader = txtHeader & vbNewLine
txtHeader = txtHeader & "Installed Programs : " & "Total Count - " & FrmMain.lstview.ListItems.Count
If InStr(gstrOS, "98") <> 0 Then
OptDetailInfo.Caption = "Long Format (Program Name and Uninstall Command)"
End If
End Sub
' This saves the report ile. it is used by Save Report Command button
' Also it is used by Print command button
Public Sub saveFile(strFile As String)
On Error GoTo errHandle:
Dim i As Integer, intFile As Integer, strTemp As String
intFile = FreeFile
Open strFile For Output As intFile
' Write the header text to file
Print #intFile, txtHeader.Text
Print #intFile, ""
With FrmMain.lstview.ListItems
' Loop thru all the items in listview and print them to file
For i = 1 To .Count
strTemp = "Display Name : " & .Item(i).Text
' Check if user has selected detailed report
If OptDetailInfo.Value = True Then
If InStr(gstrOS, "98") = 0 Then
strTemp = strTemp & vbCrLf & "Size : " & .Item(i).SubItems(1)
End If
strTemp = strTemp & vbCrLf & "Uninstall String : " & .Item(i).SubItems(4)
End If
Print #intFile, strTemp
If i <> .Count Then
Print #intFile, ""
End If
Next
End With
Close intFile
Exit Sub
errHandle:
MsgBox "Error occurred Report Save File: " & vbCrLf & Err.Description, vbCritical, App.Title
Close intFile
End Sub
' Call the printer object and prints the report file
Private Sub printFile()
On Error GoTo PrnErr:
Dim i As Integer, Lines() As String, x As Long
Printer.ScaleMode = vbInches
'Adjust the text box to the wtdth of printer
txtPrint.Width = Printer.ScaleWidth * 1440
'Call the API to wrap the text otherwise printer will not print the character exceeding the page width
'Split each line in array
Lines = Split(WYSIWYG_TextBox(txtPrint), vbNewLine)
Printer.FontName = "Lucida Console"
Printer.FontSize = 10
Printer.FontBold = False
Printer.Print ""
Printer.Print ""
Printer.Print ""
'Print each line in array
For x = 0 To UBound(Lines)
Printer.Print Lines(x)
Next
'Finish the printing
Printer.EndDoc
Exit Sub
PrnErr:
MsgBox "Error Occurred Report Print File: " & Err.Description & ", Please Check your printer", vbCritical, "Print Error !!"
End Sub
' Used to wrap the text so that long lines are wrapped
Private Function WYSIWYG_TextBox(TBox As TextBox) As String
On Error Resume Next
SendMessage TBox.hwnd, EM_FMTLINES, 1, 0#
WYSIWYG_TextBox = Replace$(TBox.Text, vbCr & vbCrLf, vbNewLine)
SendMessage TBox.hwnd, EM_FMTLINES, 0, 0#
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -