一个读写目录的程序，写得不好，请指教！
ardi_module'
'**********************************************************
'** 自动读取图纸目录信息函数 **
'** **
'**函数名：Ardi() **
'**输入参数： **
'**输出结果： **
'**注释： **
'** **
'** **
'**作者：David Ricardo **
'**版本：Ver 1.0 **
'**日期：2003.7 **
'** **
'**********************************************************
'
Sub Ardi()
'对窗体进行初始化，对listview初始化
Ardi_Form.DirInfo_ListView.View = lvwReport
Ardi_Form.DirInfo_ListView.HideColumnHeaders = False
'窗口执行
Ardi_Form.Show
End Sub '
'******************************************************************************
'** 公用变量设置区 **
'** **
'**注释：调用API对公用对话框的描述来创建一个对话框库。 **
'** **
'** **
'**版本： **
'**日期：2003.6 **
'** **
'******************************************************************************
'
Option Base 1
'打开文件对话框公用库
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4 '隐蔽只读复选框
Public Type OPENFILENAME
lStructSize As Long
hwndOwner As Long '拥有对话框的窗口
hInstance As Long
lpstrFilter As String '装载文件过滤器的缓冲区
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String '对话框的标题
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'
'******************************************************************************
'** 打开文件对话框公用函数 **
'** **
'**函数名：GetFile(strTitle As String, strFilter As String, Optional _ **
'** strIniDir As String) As String **
'**输入参数：strTitle -- 对话框标题栏，字符串变量 **
'** strFilter -- 对话框过滤器，字符串变量 **
'** strIniDir -- 初始目录，字符串变量 **
'**输出结果：字符串变量 **
'**注释：本函数通过调用API的通用对话框函数完成所要求的操作 **
'** **
'** **
'**作者： **
'**版本： **
'**日期：2003.6 **
'** **
'******************************************************************************
'
Function GetFile(strTitle As String, strFilter As String, Optional strIniDir As String) As String
On Error Resume Next
Dim FileName As String
Dim OFileBox As OPENFILENAME
With OFileBox
.lpstrTitle = strTitle '对话框标题
.lpstrInitialDir = strIniDir '初始目录
.lStructSize = Len(OFileBox)
.hwndOwner = ThisDrawing.hWnd
.flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
.lpstrFile = String$(255, 0)
.nMaxFile = 255
.lpstrFileTitle = String$(255, 0)
.nMaxFileTitle = 255
.lpstrFilter = strFilter'过滤器
.nFilterIndex = 1
End With
lntFile = GetOpenFileName(OFileBox) '执行打开对话框
If lntFile <> 0 Then
FileName = Left(OFileBox.lpstrFile, InStr(OFileBox.lpstrFile, vbNullChar) - 1)
GetFile = FileName
Else
GetFile = ""
End If
End Function
'
'******************************************************************************
'** 自动生成目录表图纸函数 **
'** **
'**函数名：Acdt() **
'**输入参数：- **
'**输出结果： **
'**注释：本函数通过读取目录数据文件（Excel），并通过插入目录图块并修改 **
'** 其属性的方式生成目录图纸。 **
'** **
'**作者：David Ricardo **
'**版本：Ver 1.1 **
'**日期：2003.6 **
'** **
'******************************************************************************
'
Sub acdt()
'定义主窗口中下拉选择框控件内容
ACDTmainForm.ComboBox_pl.AddItem "变电工程"
ACDTmainForm.ComboBox_pl.AddItem "输电工程"
ACDTmainForm.ComboBox_ev.AddItem "0.4kV"
ACDTmainForm.ComboBox_ev.AddItem "6kV"
ACDTmainForm.ComboBox_ev.AddItem "10kV"
ACDTmainForm.ComboBox_ev.AddItem "35kV"
ACDTmainForm.ComboBox_ev.AddItem "110kV"
ACDTmainForm.ComboBox_ev.AddItem "220kV"
ACDTmainForm.ComboBox_ds.AddItem "初步设计"
ACDTmainForm.ComboBox_ds.AddItem "可行性研究"
ACDTmainForm.ComboBox_ds.AddItem "施工图设计"
ACDTmainForm.ComboBox_zl.AddItem "综合"
ACDTmainForm.ComboBox_zl.AddItem "电气"
ACDTmainForm.ComboBox_zl.AddItem "土建"
ACDTmainForm.ComboBox_zl.AddItem "线路"
ACDTmainForm.ComboBox_zno.AddItem "一"
ACDTmainForm.ComboBox_zno.AddItem "二"
ACDTmainForm.ComboBox_zno.AddItem "三"
ACDTmainForm.ComboBox_zno.AddItem "四"
ACDTmainForm.ComboBox_zno.AddItem "五"
ACDTmainForm.ComboBox_zno.AddItem "六"
ACDTmainForm.ComboBox_zno.AddItem "七"
ACDTmainForm.ComboBox_zno.AddItem "八"
ACDTmainForm.ComboBox_cno.AddItem "一"
ACDTmainForm.ComboBox_cno.AddItem "二"
ACDTmainForm.ComboBox_cno.AddItem "三"
ACDTmainForm.ComboBox_cno.AddItem "四"
ACDTmainForm.ComboBox_cno.AddItem "五"
ACDTmainForm.ComboBox_cno.AddItem "六"
ACDTmainForm.ComboBox_cno.AddItem "七"
ACDTmainForm.ComboBox_cno.AddItem "八"
'窗口执行
ACDTmainForm.Show
End Sub ardi_form
'
'******************************************************************************
'** 自动读取和写入目录数据函数窗体 **
'** **
'**窗体包括的事件函数： **
'** **
'** Private Sub Cancer_ComBtn_Click()----退出窗体按钮单击事件 **
'** Private Sub DB_Browse_ComBtn_Click()----打开目录数据文件对话框按钮单_ **
'** 击事件 **
'** Private Sub Down_ComBtn_Click()----下移按钮单击事件 **
'** Private Sub DwgBrowse_ComBtn_Click()----打开图纸文件对话框按钮单击事件**
'** Private Sub Erase_ComBnt_Click()----删除按钮单击事件 **
'** Private Sub OK_ComBtn_Click()----确定按钮单击事件 **
'** Private Sub Read_ComBtn_Click()----读取目录信息并写入listview **
'** Private Sub UP_ComBtn_Click()----上移按钮单击事件 **
'** **
'** **
'**作者：David Ricardo **
'**版本：Ver 1.0 **
'**日期：2003.7 **
'** **
'** **
'******************************************************************************
'
'
'退出窗体按钮单击事件
Private Sub Cancer_ComBtn_Click()
'关闭本窗口
Unload Me
End Sub
'打开目录数据文件对话框按钮单击事件
Private Sub DB_Browse_ComBtn_Click()
Dim FileName As String
Dim title As String
title = "打开目录数据库文件..."
Dim filter As String
filter = "目录数据库文件(*.xls)" & vbNullChar & "*.xls"
FileName = GetFile(title, filter)
Ardi_Form.DBFileName_TextBox.Text = FileName
'导入表名
Dim Excel As Excel.Application
Dim ExcelWorkbook As Object
Dim I As Integer
On Error GoTo Err_Control
Set Excel = New Excel.Application
Set ExcelWorkbook = Excel.Workbooks.Open(FileName)
Ardi_Form.DB_DirTab_ComboBox.Clear
For I = 1 To ExcelWorkbook.Sheets.Count
Ardi_Form.DB_DirTab_ComboBox.AddItem (ExcelWorkbook.Sheets(I).Name)
Next I
ExcelWorkbook.Close savechanges:=False
Err_Control:
Err.Clear
'不保存关闭数据表
Excel.Application.Quit
Set ExcelWorkbook = Nothing
Set Excel = Nothing
End Sub
'下移按钮单击事件
Private Sub Down_ComBtn_Click()
Dim I As Integer
Dim Temp1 As String, Temp2 As String
If DirInfo_ListView.SelectedItem.Selected = True Then
If Not DirInfo_ListView.SelectedItem.Index = DirInfo_ListView.ListItems.Count Then
I = DirInfo_ListView.SelectedItem.Index
Temp1 = DirInfo_ListView.SelectedItem.Text
Temp2 = DirInfo_ListView.SelectedItem.SubItems(1)
DirInfo_ListView.SelectedItem.Text = DirInfo_ListView.ListItems(I + 1).Text
DirInfo_ListView.SelectedItem.SubItems(1) = DirInfo_ListView.ListItems(I + 1).SubItems(1)
DirInfo_ListView.ListItems(I + 1).Text = Temp1
DirInfo_ListView.ListItems(I + 1).SubItems(1) = Temp2
End If '(Not DirInfo_ListView.SelectedItem.Index = DirInfo_ListView.ListItems.Count)
End If '(DirInfo_ListView.SelectedItem.Selected = True)
End Sub
'打开图纸文件对话框按钮单击事件
Private Sub DwgBrowse_ComBtn_Click()
Dim OldFileName As String
Dim FileName As String
Dim title As String
Dim filter As String
title = "打开图纸文件..."
filter = "图纸文件(*.dwg)" & vbNullChar & "*.dwg"
OldFileName = Ardi_Form.DWGFileName_TextBox.Text
FileName = GetFile(title, filter)
Ardi_Form.DWGFileName_TextBox.Text = FileName
'打开选择的图纸文件
Dim DocObj As AcadDocument
If Ardi_Form.DWGFileName_TextBox.Text <> "" Then
'关闭所有的图纸文件
If Documents.Count <> 0 Then
For Each DocObj In Documents
If DocObj.WindowTitle = OldFileName Then
DocObj.Close (False)
End If '(docObj.WindowTitle = oldFileName)
Next
End If '(DocObj.count)
'打开图纸文件
ThisDrawing.Application.Documents.Open FileName
Ardi_Form.Read_ComBtn.Enabled = True
Else
Ardi_Form.Read_ComBtn.Enabled = False
End If '(Ardi_Form.DWGFileName_TextBox.Text = OldFileName)
End Sub
'删除按钮单击事件
Private Sub Erase_ComBnt_Click()
If DirInfo_ListView.SelectedItem.Selected = False Then
DirInfo_ListView.ListItems.Remove (DirInfo_ListView.ListItems.Count)
Else
DirInfo_ListView.ListItems.Remove (DirInfo_ListView.SelectedItem.Index)
End If '(DirInfo_ListView.TabIndex = "")
If DirInfo_ListView.ListItems.Count < 2 Then
Ardi_Form.UP_ComBtn.Enabled = False
Ardi_Form.Down_ComBtn.Enabled = False
End If '(DirInfo_ListView.ListItems.Count < 2)
If DirInfo_ListView.ListItems.Count < 1 Then
Ardi_Form.Erase_ComBnt.Enabled = False
End If '(DirInfo_ListView.ListItems.Count < 1)
End Sub
'确定按钮单击事件
Private Sub OK_ComBtn_Click()
Dim Excel As Excel.Application
Dim ExcelWorkbook As Object
Dim I As Integer, J As Integer
Dim HasTab As Boolean
Dim Local_Str As String
'On Error GoTo Err_Control
If Ardi_Form.DBFileName_TextBox.Text = "" Then
Exit Sub
Else
Set Excel = New Excel.Application
Set ExcelWorkbook = Excel.Workbooks.Open(Ardi_Form.DBFileName_TextBox.Text)
End If '(Ardi_Form.DBFileName_TextBox.Text = "")
If Ardi_Form.DB_DirTab_ComboBox.Text = "" Then
Exit Sub
Else
HasTab = False
For I = 1 To ExcelWorkbook.Sheets.Count
If Ardi_Form.DB_DirTab_ComboBox.Text = ExcelWorkbook.Sheets(I).Name Then
ExcelWorkbook.Sheets(I).Activate
HasTab = True
End If '(ardi_form.DB_dirTab_ComboBox.text = ExcelWorkbook.Sheets(i).Name)
Next '(i=1)
If Not HasTab Then
If MsgBox("该表不存在！是否创建？", vbYesNo) = vbYes Then
Set NewSheet = ExcelWorkbook.Sheets.Add
NewSheet.Name = Ardi_Form.DB_DirTab_ComboBox.Text
Else
Exit Sub
End If '(msgbox)
End If '(Not HasTab)
End If '(Ardi_Form.DB_DirTab_ComboBox.Text = "")
'给空表加表头
If ExcelWorkbook.ActiveSheet.Cells(1, 1) = "" Then
ExcelWorkbook.ActiveSheet.Cells(1, 1) = "序号"
ExcelWorkbook.ActiveSheet.Cells(1, 2) = "图号"
ExcelWorkbook.ActiveSheet.Cells(1, 3) = "图名"
ExcelWorkbook.ActiveSheet.Cells(1, 4) = "类别"
End If
'逐条写入目录信息
I = 1
While ExcelWorkbook.ActiveSheet.Cells(I, 1) <> ""
I = I + 1
Wend
For J = 1 To DirInfo_ListView.ListItems.Count
ExcelWorkbook.ActiveSheet.Cells(I, 1) = J
ExcelWorkbook.ActiveSheet.Cells(I, 2) = DirInfo_ListView.ListItems(J).Text
ExcelWorkbook.ActiveSheet.Cells(I, 3) = DirInfo_ListView.ListItems(J).SubItems(1)
ExcelWorkbook.ActiveSheet.Cells(I, 4) = "i"
I = I + 1
Next '(J = 1 To DirInfo_ListView.ListItems.Count)
'Err_Control:
' Err.Clear
'保存并关闭数据表
ExcelWorkbook.Close savechanges:=True
Excel.Application.Quit
Set ExcelWorkbook = Nothing
Set Excel = Nothing
'关闭本窗口
Unload Me
End Sub
'读取目录信息并写入listview
Private Sub Read_ComBtn_Click()
Dim BlkColl As AcadBlocks
Dim BlkObj As AcadBlock
Dim BlkRefObj As AcadBlockReference
Dim HaveTBBlk As Boolean, HasTBBlk As Boolean
Dim IndexNo As String, DwgNo As String, DwgName As String
Dim AttVar As Variant
'遍历图纸中的图块和块属性
HaveTBBlk = False
HasTBBlk = False
For Each BlkObj In ThisDrawing.Blocks
If LCase(BlkObj.Name) = "tb" Then
HaveTBBlk = True
Else
HaveTBBlk = False
End If '(BlkObj.Name = "tb")
HasTBBlk = HaveTBBlk Or HasTBBlk
Next '(Each BlkObj In ThisDrawing.Blocks)
If Not HasTBBlk Then
MsgBox ("本图中没有目录信息！")
Exit Sub
Else
For Each elem In ThisDrawing.ModelSpace
If elem.EntityName = "AcDbBlockReference" Then
Set BlkRefObj = elem
AttVar = BlkRefObj.GetAttributes
For I = LBound(AttVar) To UBound(AttVar)
If AttVar(I).TagString = "图号" Then
DwgNo = AttVar(I).TextString
End If '(AttVar(i).TagString = "图号")
If AttVar(I).TagString = "图名" Then
DwgName = AttVar(I).TextString
End If '(AttVar(i).TagString = "图名")
Next '(I = LBound(AttVar) To UBound(AttVar))
End If '(elem.EntityName = "AcDbBlockReference")
Next '(Each elem In ThisDrawing.ModelSpace)
End If '(Not HasTBBlk)
Set itmx = DirInfo_ListView.ListItems.Add(, , DwgNo)
itmx.SubItems(1) = DwgName
Ardi_Form.Read_ComBtn.Enabled = False
Ardi_Form.Erase_ComBnt.Enabled = True
If DirInfo_ListView.ListItems.Count > 1 Then
Ardi_Form.UP_ComBtn.Enabled = True
Ardi_Form.Down_ComBtn.Enabled = True
End If '(DirInfo_ListView.ListItems.Count > 1)
End Sub
'上移按钮单击事件
Private Sub UP_ComBtn_Click()
Dim I As Integer
Dim Temp1 As String, Temp2 As String
If DirInfo_ListView.SelectedItem.Selected = True Then
If Not DirInfo_ListView.SelectedItem.Index = 1 Then
I = DirInfo_ListView.SelectedItem.Index
Temp1 = DirInfo_ListView.SelectedItem.Text
Temp2 = DirInfo_ListView.SelectedItem.SubItems(1)
DirInfo_ListView.SelectedItem.Text = DirInfo_ListView.ListItems(I - 1).Text
DirInfo_ListView.SelectedItem.SubItems(1) = DirInfo_ListView.ListItems(I - 1).SubItems(1)
DirInfo_ListView.ListItems(I - 1).Text = Temp1
DirInfo_ListView.ListItems(I - 1).SubItems(1) = Temp2
End If '(Not DirInfo_ListView.SelectedItem.Index = 1)
End If '(DirInfo_ListView.SelectedItem.Selected = True)
End Sub '
'******************************************************************************
'** 自动生成目录图纸函数窗体代码 **
'** **
'**注释：本窗体分三大部分：第一部分为图纸标题；第二部分为目录数据文件的选择**
'** 第三部分为图纸定位。通过插入一个目录图块并修改其属性定义图纸标题，**
'** 通过读取目录数据文件并创建文字来写目录，通过用户对话来定义图纸的位**
'** 置。 **
'** **
'**窗体包括的事件函数： **
'** Cancer_button_click() -- 取消按钮单击 **
'** dir_Button_Click() -- 打开目录数据文件对话框按钮单击 **
'** local_Button_Click() -- 定位按钮单击 **
'** ok_Button_Click() -- 确定按钮单击 **
'** **
'**作者：David Ricardo **
'**版本：Ver 1.1 **
'**日期：2003.6 **
'** **
'******************************************************************************
'
'取消按钮代码
Private Sub cancer_Button_Click()
'取消工作并关闭本窗口
Unload Me
End Sub
'打开文件对话框按钮代码
Private Sub dir_Button_Click()
Dim FileName As String
Dim title As String
title = "打开文件..."
Dim filter As String
filter = "目录数据库文件(*.xls)" & vbNullChar & "*.xls"
FileName = GetFile(title, filter)
ACDTmainForm.Filename_TextBox.Text = FileName
'导入表名
Dim Excel As Excel.Application
Dim ExcelWorkbook As Object
Dim I As Integer
On Error GoTo Err_Control
Set Excel = New Excel.Application
Set ExcelWorkbook = Excel.Workbooks.Open(FileName)
I = ExcelWorkbook.Sheets.Count
For I = 1 To ExcelWorkbook.Sheets.Count
ACDTmainForm.table_Box.AddItem (ExcelWorkbook.Sheets(I).Name)
Next I
ExcelWorkbook.Close False
Err_Control:
Err.Clear
Excel.Application.Quit
Set ExcelWorkbook = Nothing
Set Excel = Nothing
ACDTmainForm.ok_Button.Enabled = True
End Sub
'定位按钮代码
Private Sub local_Button_Click()
Dim returnPnt As Variant
Dim varCancel As Variant
ACDTmainForm.hide
On Error GoTo Err_Control
returnPnt = ThisDrawing.Utility.GetPoint(, "请选择一个基点：")
'给主窗口赋值
ACDTmainForm.X_TextBox.Text = returnPnt(0)
ACDTmainForm.Y_TextBox.Text = returnPnt(1)
ACDTmainForm.Z_TextBox.Text = returnPnt(2)
Exit_Here:
ACDTmainForm.Show '显示主窗口
Exit Sub '退出子过程
Err_Control:
Select Case Err.Number
Case -2147352567 '按了取消键或其它透明命令
varCancel = ThisDrawing.GetVariable("LASTPROMPT")
If InStr(1, varCancel, "*Cancel*") <> 0 And InStr(1, varCancel, "*取消*") <> 0 Then
Err.Clear
Resume
Else
Err.Clear
Resume
End If
Case -2147467259 '右键单击或回车或空格
Err.Clear
Resume Exit_Here
Case Else
Err.Clear
Resume Exit_Here
End Select
End Sub
'确定按钮代码
(太长了，下续) (续前贴)
'确定按钮代码
Private Sub ok_Button_Click()
'读取数据库数据
Dim Excel As Excel.Application
Dim ExcelWorkbook As Object
Dim FileName As String, SheetName As Variant
Dim Count As Integer, J As Integer, I As Integer
Dim Var_ie As Integer, Var_de As Integer, Var_te As Integer, Var_be As Integer '设置图数，说明书数，清册数和概算书数变量
Dim Var_ImgName(1 To 60) As Variant, Var_ImgNo(1 To 60) As Variant
On Error GoTo Err_Control
FileName = ACDTmainForm.Filename_TextBox.Text
SheetName = ACDTmainForm.table_Box.Text
Set Excel = New Excel.Application
Set ExcelWorkbook = Excel.Workbooks.Open(FileName)
ExcelWorkbook.Sheets(SheetName).Activate
Set ExcelSheet = ExcelWorkbook.ActiveSheet
Count = 0
J = 2
Var_ie = 0
Var_de = 0
Var_te = 0
Var_be = 0
While ExcelSheet.Cells(J, 1).Value <> ""
Count = Count + 1
J = J + 1
Wend
For I = 1 To Count
If ExcelSheet.Cells(I + 1, 4).Value = "d" Then
Var_de = Var_de + 1
End If '计算说明书数
If ExcelSheet.Cells(I + 1, 4).Value = "b" Then
Var_be = Var_be + 1
End If '计算概算书数
If ExcelSheet.Cells(I + 1, 4).Value = "t" Then
Var_te = Var_te + 1
End If '计算清册数
If ExcelSheet.Cells(I + 1, 4).Value = "i" Then
Var_ie = Var_ie + 1
End If '计算图纸数
If ExcelSheet.Cells(I + 1, 3).Value <> "" Then
Var_ImgName(I) = ExcelSheet.Cells(I + 1, 3).Value
Else
Var_ImgName(I) = " "
End If '读图名
If ExcelSheet.Cells(I + 1, 2).Value <> "" Then
Var_ImgNo(I) = ExcelSheet.Cells(I + 1, 2).Value
Else
Var_ImgNo(I) = " "
End If '读图号
Next I
ExcelWorkbook.Close False
Excel.Application.Quit
Err_Control:
Err.Clear
Set ExcelWorkbook = Nothing
Set Excel = Nothing
'插入一个块
Dim BasePnt(0 To 2) As Double, BasePnt1(0 To 2) As Double
Dim InsBlk1 As AcadBlockReference, InsBlk2 As AcadBlockReference
BasePnt(0) = ACDTmainForm.X_TextBox.Text
BasePnt(1) = ACDTmainForm.Y_TextBox.Text
BasePnt(2) = ACDTmainForm.Z_TextBox.Text
Set InsBlk1 = ThisDrawing.ModelSpace.InsertBlock(BasePnt, "mlb-1.dwg", 1, 1, 1, 0)
If Count > 28 Then
BasePnt1(0) = ACDTmainForm.X_TextBox.Text + 210
BasePnt1(1) = ACDTmainForm.Y_TextBox.Text
BasePnt1(2) = ACDTmainForm.Z_TextBox.Text
Set InsBlk2 = ThisDrawing.ModelSpace.InsertBlock(BasePnt1, "mlb-2.dwg", 1, 1, 1, 0)
End If
'给块属性赋值的定义部分
Dim Str_pn, Str_ds, Str_zl, Str_zno, Str_cno, Str_zcn As String
Dim Str_ino, Str_pag As String, Var_y, Var_m
Dim Str_ie As String, Str_de As String, Str_te As String, Str_be As String
Dim Ind_pl, Ind_ev, Ind_pno, Ind_ds, Ind_zl, Ind_zno, Ind_cno As String
'给块属性赋值
If ACDTmainForm.TextBox_pn.Text <> "" Then
Str_pn = ACDTmainForm.TextBox_pn.Text
Else
Str_pn = " "
End If '工程名称
If ACDTmainForm.ComboBox_ds.Text <> "" Then
Str_ds = ACDTmainForm.ComboBox_ds.Text
Else
Str_ds = " "
End If
Select Case Str_ds
Case "初步设计"
Ind_ds = "C"
Case "可行性研究"
Ind_ds = "G"
Case "施工图设计"
Ind_ds = "S"
Case Else
Ind_ds = "*"
End Select '设计阶段
If ACDTmainForm.ComboBox_zl.Text <> "" Then
Str_zl = ACDTmainForm.ComboBox_zl.Text
Else
Str_zl = " "
End If
Select Case Str_zl
Case "电气"
Ind_zl = "D"
Case "综合"
Ind_zl = "A"
Case "土建"
Ind_zl = "T"
Case "线路"
Ind_zl = "V"
Case Else
Ind_zl = "*"
End Select '专业类别
If ACDTmainForm.ComboBox_zno.Text <> "" Then
Str_zno = ACDTmainForm.ComboBox_zno.Text
Else
Str_zno = " "
End If
Select Case Str_zno
Case "一"
Ind_zno = "01"
Case "二"
Ind_zno = "02"
Case "三"
Ind_zno = "03"
Case "四"
Ind_zno = "04"
Case "五"
Ind_zno = "05"
Case "六"
Ind_zno = "06"
Case "七"
Ind_zno = "07"
Case "八"
Ind_zno = "08"
Case Else
Ind_zno = "**"
End Select '卷号
If ACDTmainForm.ComboBox_cno.Text <> "" Then
Str_cno = ACDTmainForm.ComboBox_cno.Text
Else
Str_cno = " "
End If
Select Case Str_cno
Case "一"
Ind_cno = "01"
Case "二"
Ind_cno = "02"
Case "三"
Ind_cno = "03"
Case "四"
Ind_cno = "04"
Case "五"
Ind_cno = "05"
Case "六"
Ind_cno = "06"
Case "七"
Ind_cno = "07"
Case "八"
Ind_cno = "08"
Case Else
Ind_cno = "**"
End Select '册号
If ACDTmainForm.TextBox_zcn.Text <> "" Then
Str_zcn = ACDTmainForm.TextBox_zcn.Text
Else
Str_zcn = " "
End If '卷册名称
Select Case CStr(Var_ie)
Case "0"
Str_ie = " "
Case Else
Str_ie = CStr(Var_ie)
End Select '设置图纸数
Select Case CStr(Var_de)
Case "0"
Str_de = " "
Case Else
Str_de = CStr(Var_de)
End Select '设置说明书数
Select Case CStr(Var_te)
Case "0"
Str_te = " "
Case Else
Str_te = CStr(Var_te)
End Select '设置清册数
Select Case CStr(Var_be)
Case "0"
Str_be = " "
Case Else
Str_be = CStr(Var_be)
End Select '设置概算书数
Select Case ACDTmainForm.ComboBox_pl.Text
Case "变电工程"
Ind_pl = "B"
Case "输电工程"
Ind_pl = "S"
Case Else
Ind_pl = "*"
End Select '读工程类别
Select Case ACDTmainForm.ComboBox_ev.Text
Case "0.4kV"
Ind_ev = "1"
Case "6kV"
Ind_ev = "2"
Case "10kV"
Ind_ev = "3"
Case "35kV"
Ind_ev = "4"
Case "110kV"
Ind_ev = "5"
Case "220kV"
Ind_ev = "6"
Case Else
Ind_ev = "*"
End Select '读电压等级
If ACDTmainForm.TextBox_pno.Text <> "" Then
Ind_pno = ACDTmainForm.TextBox_pno.Text
Else
Ind_pno = "***"
End If '读工程序号
Str_ino = Ind_pl + Ind_ev + Ind_pno + Ind_ds + "-" + Ind_zl + Ind_zno + Ind_cno '设置卷册检索号
If Count < 28 Then
Str_pag = "1"
Else
Str_pag = "2"
End If '设置总页数
Var_y = Year(Now) '设置年
Var_m = Month(Now) '设置月
'更改块属性
Dim Att_Var1 As Variant, Att_Var2 As Variant
Att_Var1 = InsBlk1.GetAttributes
Att_Var1(0).TextString = Str_pn
Att_Var1(1).TextString = Str_ds
Att_Var1(2).TextString = Str_zl
Att_Var1(3).TextString = Str_zno
Att_Var1(4).TextString = Str_cno
Att_Var1(5).TextString = Str_zcn
Att_Var1(6).TextString = Str_ie
Att_Var1(7).TextString = Str_de
Att_Var1(8).TextString = Str_te
Att_Var1(9).TextString = Str_be
Att_Var1(10).TextString = Str_ino
Att_Var1(11).TextString = "1"
Att_Var1(12).TextString = Str_pag
Att_Var1(13).TextString = CStr(Var_y)
Att_Var1(14).TextString = CStr(Var_m)
If Count > 28 Then
Att_Var2 = InsBlk2.GetAttributes
Att_Var2(0).TextString = Str_pn
Att_Var2(1).TextString = Str_ds
Att_Var2(2).TextString = Str_zl
Att_Var2(3).TextString = Str_zno
Att_Var2(4).TextString = Str_cno
Att_Var2(5).TextString = Str_zcn
Att_Var2(6).TextString = Str_ino
Att_Var2(7).TextString = "2"
Att_Var2(8).TextString = Str_pag
Att_Var2(9).TextString = CStr(Var_y)
Att_Var2(10).TextString = CStr(Var_m)
End If
'写目录数据
Dim TextObj As AcadText
Dim Num_Str As String
Dim Ins_Pnt1(0 To 2) As Double, Ins_Pnt2(0 To 2) As Double
Dim Ins_Pnt3(0 To 2) As Double, Ins_Pnt4(0 To 2) As Double
Dim Height As Double
Height = 2.5 '确定字体高度
'确定文字初始位置
Ins_Pnt1(0) = BasePnt(0) + 40
Ins_Pnt1(1) = BasePnt(1) + 207
Ins_Pnt1(2) = 0
Ins_Pnt2(0) = Ins_Pnt1(0) + 25
Ins_Pnt2(1) = Ins_Pnt1(1)
Ins_Pnt2(2) = 0
Ins_Pnt3(0) = Ins_Pnt2(0) + 22
Ins_Pnt3(1) = Ins_Pnt1(1)
Ins_Pnt3(2) = 0
Ins_Pnt4(0) = Ins_Pnt3(0) + 83
Ins_Pnt4(1) = Ins_Pnt1(1)
Ins_Pnt4(2) = 0
If Count < 28 Then '如果只有一页目录
For I = 1 To Count '写第一页目录
Set TextObj = ThisDrawing.ModelSpace.AddText(CStr(I), Ins_Pnt1, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt1
Set TextObj = ThisDrawing.ModelSpace.AddText(Var_ImgNo(I), Ins_Pnt2, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt2
Set TextObj = ThisDrawing.ModelSpace.AddText(Var_ImgName(I), Ins_Pnt3, Height)
TextObj.Alignment = acAlignmentMiddleLeft
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt3
Set TextObj = ThisDrawing.ModelSpace.AddText("1", Ins_Pnt4, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt4
Ins_Pnt1(1) = Ins_Pnt1(1) - 7
Ins_Pnt2(1) = Ins_Pnt2(1) - 7
Ins_Pnt3(1) = Ins_Pnt3(1) - 7
Ins_Pnt4(1) = Ins_Pnt4(1) - 7
Next I
Else '如果存在第二页目录
For I = 1 To 28 '先写第一页目录
Set TextObj = ThisDrawing.ModelSpace.AddText(CStr(I), Ins_Pnt1, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt1
Set TextObj = ThisDrawing.ModelSpace.AddText(Var_ImgNo(I), Ins_Pnt2, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt2
Set TextObj = ThisDrawing.ModelSpace.AddText(Var_ImgName(I), Ins_Pnt3, Height)
TextObj.Alignment = acAlignmentMiddleLeft
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt3
Set TextObj = ThisDrawing.ModelSpace.AddText("1", Ins_Pnt4, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt4
Ins_Pnt1(1) = Ins_Pnt1(1) - 7
Ins_Pnt2(1) = Ins_Pnt2(1) - 7
Ins_Pnt3(1) = Ins_Pnt3(1) - 7
Ins_Pnt4(1) = Ins_Pnt4(1) - 7
Next I
Ins_Pnt1(0) = Ins_Pnt1(0) + 210
Ins_Pnt1(1) = Ins_Pnt1(1) + 217
Ins_Pnt2(0) = Ins_Pnt2(0) + 210
Ins_Pnt2(1) = Ins_Pnt2(1) + 217
Ins_Pnt3(0) = Ins_Pnt3(0) + 210
Ins_Pnt3(1) = Ins_Pnt3(1) + 217
Ins_Pnt4(0) = Ins_Pnt4(0) + 210
Ins_Pnt4(1) = Ins_Pnt4(1) + 217
For I = 29 To Count '写第二页目录
Set TextObj = ThisDrawing.ModelSpace.AddText(CStr(I), Ins_Pnt1, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt1
Set TextObj = ThisDrawing.ModelSpace.AddText(Var_ImgNo(I), Ins_Pnt2, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt2
Set TextObj = ThisDrawing.ModelSpace.AddText(Var_ImgName(I), Ins_Pnt3, Height)
TextObj.Alignment = acAlignmentMiddleLeft
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt3
Set TextObj = ThisDrawing.ModelSpace.AddText("1", Ins_Pnt4, Height)
TextObj.Alignment = acAlignmentMiddle
TextObj.ScaleFactor = 0.9
TextObj.ObliqueAngle = 0.175
TextObj.TextAlignmentPoint = Ins_Pnt4
Ins_Pnt1(1) = Ins_Pnt1(1) - 7
Ins_Pnt2(1) = Ins_Pnt2(1) - 7
Ins_Pnt3(1) = Ins_Pnt3(1) - 7
Ins_Pnt4(1) = Ins_Pnt4(1) - 7
Next I
End If
'关闭本窗口
Unload Me
End Sub 以上所有程序是在各位的帮助下完成，万分感谢班主和各位的帮助，希望大家能给我的程序提出宝贵意见。再次谢谢大家！ 请问这个程序怎么用呀 老师是写的好，要将它作为一个统一窗体贴出来才直观 太复杂了,看不懂,学习中。 你直接贴上源码不就可以了么？
页:
[1]
2