一个读写目录的程序，写得不好，请指教！

3kd

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

3kd

'
'******************************************************************************
'**                              公用变量设置区                              **
'**                                                                          **
'**注释：调用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

3kd

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

3kd

'
'******************************************************************************
'**                       自动生成目录图纸函数窗体代码                       **
'**                                                                          **
'**注释：本窗体分三大部分：第一部分为图纸标题；第二部分为目录数据文件的选择  **
'**      第三部分为图纸定位。通过插入一个目录图块并修改其属性定义图纸标题，  **
'**      通过读取目录数据文件并创建文字来写目录，通过用户对话来定义图纸的位  **
'**      置。                                                                **
'**                                                                          **
'**窗体包括的事件函数：                                                      **
'**           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

'确定按钮代码

(太长了，下续)

3kd

(续前贴)

'确定按钮代码

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

3kd

以上所有程序是在各位的帮助下完成，万分感谢班主和各位的帮助，希望大家能给我的程序提出宝贵意见。再次谢谢大家！

luobg73

请问这个程序怎么用呀

清风明月名字

老师是写的好，要将它作为一个统一窗体贴出来才直观

njyulei

太复杂了,看不懂,学习中。

rensd

你直接贴上源码不就可以了么？