[原创]宁靖盐高速公路养护工程计量辅助系统【开发全功略】

mrstian

在论坛大家的帮助的下，《宁靖盐高速公路养护工程计量辅助系统》终于完成了，准备在5月16日在我们单位使用，现在先拿出来与大家分享。欢迎大家下载、交流！ 在此也特别感谢taller等高手给予的帮助！ 一、系统概述： 《宁靖盐高速公路养护工程计量辅助系统》是《江苏省宁靖盐高速公路维修保养管理系统》的补充，是养护工程计量中的得力助手，系统已经过多次调试、更新，并通过了瑞星杀毒软件的防病毒检测，目前版本号为3.0。 1、主要功能： 按细目自动汇总累加、自动排版打印、台帐综合查询、数据库管理等； 2、行业应用： 社会化高速公路养护管理。 二、涉及的知识点： 1、EXCEL表格设计和vba程序编写； 所需软件：Microsoft Excel XP（最好是officexp的全安装） 2、程序封装； 所需软件：Visual Basic 6.0 3、安装程序制作： 所需软件：Wise Installation9.02 三、程序中部分代码及说明： 见后贴。 四、程序下载： №1： 提示： 1、将上面7个压缩包（必须在同一目录下）全部下载后； 2、依次将7个压缩包重新命名为BYNJYsetup.part1.rar、BYNJYsetup.part2.rar、......、BYNJYsetup.part7.rar； 3、按照提示执行BYNJYsetup.part1压缩包的解压缩即可。 4、初始密码是：7980 源文件在104 楼.

[此贴子已经被作者于2004-5-15 12:20:06编辑过]

mrstian

欢迎大家提出宝贵意见和建议，
你的建议我将虚心接受！
你的问题我将耐心解答！
==========================
1、程序封装后启动窗口代码及说明：

做启动窗口可以达到绕开excel是否启用宏对话框的目的，也可以美化程序界面，使程序看上去好象是脱离了excel运行。那它是怎么做的呢？请看：
① 打开vb程序新建一个工程，做一个如上图的窗体；
② 右击窗体选择查看代码，加入以下代码：
Private Sub Timer1_Timer()
Dim Exl As Object
Set Exl = CreateObject("Excel.Application")
Exl.Workbooks.Open (App.Path & "\" & "main.by")
Exl.Visible = True
Unload Me
End Sub
③ 将属性timer设置为1000；
④ 再对form属性进行相关设置，如设置StatUpPosition为2-屏幕中心。

[此贴子已经被作者于2004-3-29 16:37:37编辑过]

crj

代码写得不错，最关键是封装得好！对公路行业有一点帮助，是公路行业实用价值。

[此贴子已经被作者于2004-2-25 19:21:28编辑过]

班长

无法解压。如何打开？请指点。

[此贴子已经被作者于2004-2-25 19:47:11编辑过]

crj

把开第一个就可以解压，然后选第二、三……

szxfzx

把第一个改名为1.rar，第二个改为2.rar，依次类推。然后点任何一个解压就可以了。

chyzhen20

同志啊，包装很不错哦！密码在哪呢？

情非得已

请问密码是多少？

情非得已

怎么连一个Excel 文档都没有？

mrstian

楼上朋友回答的问题在no1贴我已修改，即做了回答
=====================================
2、带指示进度的汇总宏及说明：

② 新建一个宏，代码为：
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Sub main()
Dim ph As String
Dim fs, f, f1, fc, s, shtName, aa, ir, ic
Dim i, StartRow, StopRow, NStartRow As Integer
Dim myApp As New Application, wkSht As Worksheet ph = BrowDir()
If ph <> "" Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
shtName = Application.InputBox("请按规范输入表格名称（5200405）")
Worksheets.add.Name = shtName
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ph)
Set fc = f.Files
i = 0
Guage.Show 0
If VBA.right(ph, 1) <> "\" Then ph = ph & "\"
For Each f1 In fc
If VBA.UCase(VBA.right(f1.Name, 3)) = "XLS" Then
i = i + 1
CloseSame f1.Name
Set wkSht = myApp.Workbooks.Open(ph & f1.Name).Sheets(1)

If i = 1 Then
wkSht.UsedRange.Select
Else
ir = wkSht.UsedRange.Rows.Count
ic = wkSht.UsedRange.Columns.Count
wkSht.UsedRange.Offset(1, 0).Resize(ir - 1, ic).Select
End If
wkSht.Application.Selection.Copy
NStartRow = IIf(ActiveSheet.[F65536].End(xlUp).Row = 1, 1, ActiveSheet.[F65536].End(xlUp).Row + 1)
ActiveSheet.Cells(NStartRow, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
wkSht.[a1].Copy
myApp.Quit
Set wkSht = Nothing
Set myApp = Nothing

End If
Guage.Label2.Caption = Int((100 / f.Files.Count) * i) & "%"
Guage.Label1.Width = 220 * i / f.Files.Count
DoEvents
Next
ActiveSheet.UsedRange.Select
Selection.Rows.AutoFit
Selection.Columns.AutoFit
Range("a2").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = True
If i > 0 Then MsgBox "月度计量汇总完成", vbInformation, "系统提示
End If
Unload Guage
Sheet3.AddItem
End Sub
Function BrowDir() As String
Dim bi As BROWSEINFO
Dim pidl&, rtn&, path$, pos%, mypath
pidl& = SHBrowseForFolder(bi)
path$ = VBA.space$(512)
rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$)
If rtn& Then
pos% = InStr(path$, VBA.chr$(0))
mypath = VBA.left(path$, pos - 1)
End If
BrowDir = mypath
End Function
Sub CloseSame(ss As String)
Dim i
For i = 1 To Application.Windows.Count
If VBA.UCase(Application.Windows(i).Caption) = VBA.UCase(ss) Then
Application.Windows(i).Close False
Exit Sub
End If
Next i
End Sub
这样一个带进度指示的汇总宏就完成了。

[此贴子已经被作者于2004-3-29 16:40:13编辑过]