图纸集的页码问题悬而未决!!(非通晓图纸集者勿入)

zeiss · 发表于 2012-10-11 18:06

Option Explicit

Private Sub Check3_Click()
If Check3.Value = 1 Then
cboBlkDefs.Enabled = True
Else
cboBlkDefs.Enabled = False
End If
End Sub

Private Sub Command1_Click()
Dim sectionlayer As Object '图层下图元选择集
Dim i As Integer
If Option1(0).Value = True Then
'删除原图层中的图元
Set sectionlayer = FilterSSet("sectionlayer", 8, "插入模型页码", 67, "0") '得到图层下图元
sectionlayer.erase
sectionlayer.Delete
Call AddYMtoModelSpace
Else
Set sectionlayer = FilterSSet("sectionlayer", 8, "插入布局页码", 67, "1") '得到图层下图元
'注意：这里必须用循环的方法删除，不能用sectionlayer.erase，因为多个布局会发生错误
If sectionlayer.count > 0 Then
      For i = 0 To sectionlayer.count - 1
         sectionlayer.Item(i).Delete
      Next
End If
sectionlayer.Delete
Call AddYMtoPaperSpace
End If
End Sub
Private Sub AddYMtoPaperSpace()

Dim sectionText As Object, sectionMText As Object, i As Integer, anobj As Object
Dim ArrObjs() As Object, ArrLayoutNames() As String, ArrTabOrders() As Integer '第X页的信息
Dim ArrObjsAll() As Object, ArrLayoutNamesAll() As String '共X页的信息
Dim flag As Boolean '是否存在页码
flag = False
'定义三个数组，分别放置页码对象、页码对象所在布局的标签名、页码对象所在的标签在所有标签中的位置
If Check1.Value = 1 Then
      '加入单行文字
      Set sectionText = FilterSSet("sectionText", 67, "1", 0, "TEXT") '得到text
      For i = 0 To sectionText.count - 1
         Set anobj = sectionText(i)
         If VBA.Left(Trim(anobj.textString), 1) = "第" And VBA.Right(Trim(anobj.textString), 1) = "页" Then
            '把第X页增加到数组中
            Call Getowner(anobj, ArrObjs, ArrLayoutNames, ArrTabOrders)
            flag = True
         ElseIf VBA.Left(Trim(anobj.textString), 1) = "共" And VBA.Right(Trim(anobj.textString), 1) = "页" Then
            '把共X页增加到数组中
            Call GetownerAll(anobj, ArrObjsAll, ArrLayoutNamesAll)
         End If
      Next
End If

If Check2.Value = 1 Then
      '加入多行文字
      Set sectionMText = FilterSSet("sectionMText", 67, "1", 0, "MTEXT") '得到Mtext
      For i = 0 To sectionMText.count - 1
         Set anobj = sectionMText(i)
         If VBA.Left(Trim(anobj.textString), 1) = "第" And VBA.Right(Trim(anobj.textString), 1) = "页" Then
            '把第X页增加到数组中
            Call Getowner(anobj, ArrObjs, ArrLayoutNames, ArrTabOrders)
            flag = True
         ElseIf VBA.Left(Trim(anobj.textString), 1) = "共" And VBA.Right(Trim(anobj.textString), 1) = "页" Then
            '把共X页增加到数组中
            Call GetownerAll(anobj, ArrObjsAll, ArrLayoutNamesAll)
         End If
      Next
End If

'判断是否有页码
If flag = False Then
      MsgBox "没有找到页码"
      Exit Sub
End If

'得到了3个数组，接下来根据ArrLayoutNames得到对应layout.item(i)中的i,
Dim ArrItemI As Variant, ArrItemIAll As Variant
ArrItemI = GetNametoI(ArrLayoutNames)
ArrItemIAll = GetNametoI(ArrLayoutNamesAll)
'接下来按照ArrTabOrders里面的数字按从小到大排列其他两个数组ArrItemI及ArrObjs
Call PopoArr(ArrTabOrders, ArrObjs, ArrItemI)

'接下来在布局中写字
Dim minExt As Variant, maxExt As Variant, midExt As Variant
'先得到页码的字体样式
Dim tempname As String, tempheight As Double
tempname = ArrObjs(0).stylename
tempheight = ArrObjs(0).Height
'设置文字样式
Dim currTextStyle As Object
Set currTextStyle = ThisDrawing.TextStyles(tempname)
ThisDrawing.ActiveTextStyle = currTextStyle '设置当前文字样式
'设置图层
Dim Textlayer As Object
Set Textlayer = ThisDrawing.Layers.Add("插入布局页码")
Textlayer.Color = 1
ThisDrawing.ActiveLayer = Textlayer
'得到第x页字体中心点并画画
For i = 0 To UBound(ArrObjs)
      Set anobj = ArrObjs(i)
      Call GetBounding(anobj, minExt, maxExt) '得到所写字体的外边框左下角和右上角的坐标
      midExt = centerPoint(minExt, maxExt) '得到中心点
      Call AcadText_paperspace(i + 1, midExt, tempheight, ArrItemI(i))
Next
'得到共x页字体中心点并画画
Dim tempi As String
tempi = UBound(ArrObjsAll) + 1
For i = 0 To UBound(ArrObjsAll)
      Set anobj = ArrObjsAll(i)
      Call GetBounding(anobj, minExt, maxExt) '得到所写字体的外边框左下角和右上角的坐标
      midExt = centerPoint(minExt, maxExt) '得到中心点
      Call AcadText_paperspace(tempi, midExt, tempheight, ArrItemIAll(i))
Next

MsgBox "OK了"
End Sub
'得到某的图元所在的布局
'入口：图元。及图元的相关信息数组，出口：增加一个信息后的数组
Sub Getowner(ent As Object, ArrObjs, ArrLayoutNames, ArrTabOrders)

Dim owner As Object
Set owner = ThisDrawing.ObjectIdToObject(ent.OwnerID)
If IsArrayEmpty(ArrLayoutNames) = True Then '如果是第一个
ReDim ArrObjs(0)
ReDim ArrLayoutNames(0)
ReDim ArrTabOrders(0)
Set ArrObjs(0) = ent
ArrLayoutNames(0) = owner.Layout.Name
ArrTabOrders(0) = owner.Layout.TabOrder
Else
ReDim Preserve ArrObjs(UBound(ArrObjs) + 1) '增加一个
ReDim Preserve ArrLayoutNames(UBound(ArrLayoutNames) + 1) '增加一个
ReDim Preserve ArrTabOrders(UBound(ArrTabOrders) + 1) '增加一个
Set ArrObjs(UBound(ArrObjs)) = ent
ArrLayoutNames(UBound(ArrLayoutNames)) = owner.Layout.Name
ArrTabOrders(UBound(ArrTabOrders)) = owner.Layout.TabOrder
End If
End Sub
'得到某的图元所在的布局
'入口：图元。及图元的相关信息数组，出口：增加一个信息后的数组
Sub GetownerAll(ent As Object, ArrObjs, ArrLayoutNames)

Dim owner As Object
Set owner = ThisDrawing.ObjectIdToObject(ent.OwnerID)
If IsArrayEmpty(ArrLayoutNames) = True Then '如果是第一个
ReDim ArrObjs(0)
ReDim ArrLayoutNames(0)
Set ArrObjs(0) = ent
ArrLayoutNames(0) = owner.Layout.Name
Else
ReDim Preserve ArrObjs(UBound(ArrObjs) + 1) '增加一个
ReDim Preserve ArrLayoutNames(UBound(ArrLayoutNames) + 1) '增加一个
Set ArrObjs(UBound(ArrObjs)) = ent
ArrLayoutNames(UBound(ArrLayoutNames)) = owner.Layout.Name
End If
End Sub
Private Sub AddYMtoModelSpace()
Dim sectionText As Object, sectionMText As Object, sectionBlock As Object, SSetobjBlkDefText As Object '图块中文字的集合
If Check1.Value = 1 Then Set sectionText = FilterSSet("sectionText", 0, "TEXT", 67, "0") '得到text
If Check2.Value = 1 Then Set sectionMText = FilterSSet("sectionMText", 0, "MTEXT", 67, "0") '得到Mtext
If Check3.Value = 1 Then
      If cboBlkDefs.Text = "全部" Then
         Set sectionBlock = FilterSSet("sectionBlock ", 0, "INSERT", 67, "0") '得到插入的BLOCK.0表示模型，1 表示布局中的图元
      Else
         Set sectionBlock = FilterSSet("sectionBlock ", 0, "INSERT", 67, "0", 2, cboBlkDefs.Text)
      End If
      Set SSetobjBlkDefText = CreateSelectionSet("SSetobjBlkDefText")
      Set SSetobjBlkDefText = AddbjBlkDeftextToSSet(sectionBlock) '得到当前N多块的text的选择集
End If

Dim i As Integer
Dim minExt As Variant, maxExt As Variant, midExt As Variant

'先创建一个所有页码的选择集
Dim SSetd As Object '第X页页码的集合
Dim SSetz As Object '共X页页码的集合

Set SSetd = CreateSelectionSet("sectionYmd")
Set SSetz = CreateSelectionSet("sectionYmz")

'接下来把文字选择集中包含页码的对象创建成一个页码选择集
Call AddYmToSSet(SSetd, SSetz, sectionText)
Call AddYmToSSet(SSetd, SSetz, sectionMText)
Call AddYmToSSet(SSetd, SSetz, SSetobjBlkDefText)

If SSetd.count = 0 Then
      MsgBox "没有找到页码"
      Exit Sub
End If

'选择集输出为数组然后排序
Dim XuanZJ As Variant
XuanZJ = ExportSSet(SSetd)
'接下来按照x轴从小到大排列
Call PopoAsc(XuanZJ)

   '把不用的选择集删除
SSetd.Delete
If Check1.Value = 1 Then sectionText.Delete
If Check2.Value = 1 Then sectionMText.Delete

'接下来写入页码

zeiss · 发表于 2012-10-11 18:07

'先得到页码的字体样式
Dim tempname As String, tempheight As Double
tempname = XuanZJ(0).stylename
tempheight = XuanZJ(0).Height
'设置文字样式
Dim currTextStyle As Object
Set currTextStyle = ThisDrawing.TextStyles(tempname)
ThisDrawing.ActiveTextStyle = currTextStyle '设置当前文字样式
'设置图层
Dim Textlayer As Object
Set Textlayer = ThisDrawing.Layers.Add("插入模型页码")
Textlayer.Color = 1
ThisDrawing.ActiveLayer = Textlayer

'得到第x页字体中心点并画画
Dim anobj As Object
For i = 0 To UBound(XuanZJ)
      Set anobj = XuanZJ(i)
      Call GetBounding(anobj, minExt, maxExt) '得到所写字体的外边框左下角和右上角的坐标
      midExt = centerPoint(minExt, maxExt) '得到中心点
      Call AcadText_c(i + 1, midExt, tempheight)
Next
'得到共x页字体中心点并画画
Dim YMZ As String
YMZ = i
For i = 0 To SSetz.count - 1
      Set anobj = SSetz.Item(i)
      Call GetBounding(anobj, minExt, maxExt) '得到所写字体的外边框左下角和右上角的坐标
      midExt = centerPoint(minExt, maxExt) '得到中心点
      Call AcadText_c(YMZ, midExt, tempheight)
Next
If Check3.Value = 1 Then
'接下来把块中对应的第X页共X页等text删除
      SSetobjBlkDefText.erase
      SSetobjBlkDefText.Delete
End If
MsgBox "OK了"
End Sub
'入口页码选择集(第X页和共X页)，和文字选择集
Private Sub AddYmToSSet(SSetd As Object, SSetz As Object, sectionTextName)
Dim anobj As Object, anobjs As Variant
Dim NumberObj As Integer, tempStr As String
If sectionTextName Is Nothing Then
'
Else
If sectionTextName.count > 0 Then
      For NumberObj = 0 To sectionTextName.count - 1
         Set anobj = sectionTextName.Item(NumberObj)
         If anobj.ObjectName = "AcDbText" Then '如果为单行文字
            If VBA.Left(Trim(anobj.textString), 1) = "第" And VBA.Right(Trim(anobj.textString), 1) = "页" Then '如果左边第一个是第,最后一个是页
                  '把对象添加到选择集中
                  Call AddEntToSSet(anobj, SSetd)
            ElseIf VBA.Left(Trim(anobj.textString), 1) = "共" And VBA.Right(Trim(anobj.textString), 1) = "页" Then '如果左边第一个是共,最后一个是页
                  Call AddEntToSSet(anobj, SSetz)
            End If
         ElseIf anobj.ObjectName = "AcDbMText" Then '如果为多行文字
            '分两种情况。1.没有格式2.有格式
            '没有格式的同单行文字
            If VBA.Right(Trim(anobj.textString), 1) = "页" Then
                  If VBA.Left(Trim(anobj.textString), 1) = "第" Then '如果左边第一个是第,最后一个是页
                     '把对象添加到选择集中
                     Call AddEntToSSet(anobj, SSetd)
                  ElseIf VBA.Left(Trim(anobj.textString), 1) = "共" Then '如果左边第一个是共,最后一个是页
                     Call AddEntToSSet(anobj, SSetz)
                  End If
            '以上两种情况是属于情况一，没有格式的
            ElseIf VBA.Left(VBA.Trim(anobj.textString), 1) = "{" And VBA.Right(Trim(anobj.textString), 2) = "页}" Then '有格式的
                  tempStr = Segmentation(VBA.Trim(anobj.textString)) '得到有格式的多行文字中最后一段字符串
                  If VBA.Left(tempStr, 1) = "第" Then '如果左边第一个是第,最后一个是页
                     '把对象添加到选择集中
                     Call AddEntToSSet(anobj, SSetd)
                  ElseIf VBA.Left(tempStr, 1) = "共" Then '如果左边第一个是共,最后一个是页
                     Call AddEntToSSet(anobj, SSetz)
                  End If
            End If

         End If
      Next
End If
End If
End Sub
'出口：返回图块选择集中的所有文字的选择集
'入口：图块选择集
Private Function AddbjBlkDeftextToSSet(SSetBlock As Object) As Object '把图块中的文字添加到选择集中

Dim objBlkDef As Object
Dim tempsset As Object, tempssetall As Object
Set tempsset = CreateSelectionSet("tempsset") '临时选择集
Set tempssetall = CreateSelectionSet("tempssetall") '临时选择集
Dim i As Integer
For i = 0 To SSetBlock.count - 1
      If StrComp(Left(SSetBlock.Item(i).Name, 1), "*") <> 0 Then '除去匿名块
         'MsgBox objBlkDef.ObjectName & objBlkDef.Name
         Set tempsset = GetBlockTextSS(SSetBlock.Item(i))
         'tempsset = TextSS(SSetBlock.Item(i))
         If tempsset.count > 0 Then Call AddEntsToSSet(tempsset, tempssetall) '合并两个选择集
      End If
Next
Set AddbjBlkDeftextToSSet = tempssetall
End Function

Private Sub Form_Load()
' 将当前图形中定义的所有块定义名称添加到组合框中
Dim objBlkDef As Object
For Each objBlkDef In ThisDrawing.Blocks
      ' 不将模型空间、图纸空间和匿名块添加到列表中
      If StrComp(Left(objBlkDef.Name, 1), "*") <> 0 Then
         cboBlkDefs.AddItem objBlkDef.Name
      End If
Next objBlkDef

' 将列表框的第一个元素设置为被选择的元素
If cboBlkDefs.ListCount > 0 Then
      cboBlkDefs.AddItem "全部"
      cboBlkDefs.ListIndex = cboBlkDefs.ListCount - 1
End If

ThisDrawing.SetVariable "LAYOUTREGENCTL", 2

End Sub

Private Sub Option1_Click(Index As Integer)
If Index = 1 Then
Check3.Enabled = False
cboBlkDefs.Enabled = False
ElseIf Index = 0 Then
Check3.Enabled = True
cboBlkDefs.Enabled = True
End If

End Sub

zeiss · 发表于 2012-10-11 18:08

放了2段源代码，帖子的长度有限制，分成两段了。合起来就是个vba程序，哪位熟悉vba的，调试一下。最好存成dvb格式的文件，方便直接调用。原帖见：
http://hi.baidu.com/kakanimo/item/3333a8267ccd338a9c63d15b

3278 · 发表于 2013-3-23 14:02

我也是让这问题困扰了好几年了一直没有找到解决方法

dnntso · 发表于 2013-9-19 22:56

跨度好久，你也蛮坚持的，感觉总页数交给ＣＡＤ，你已解决，第几页这个活交个ＰＤＦ软件吧。

dnntso · 发表于 2013-9-24 06:35

发现海龙工具箱，有个高级编号功能，里面有序号递增。可以解决第几页问题，
同样又有另一问题，海龙是一布局Ｎ图框，又与图纸集冲突。

不过买了正式版海龙，习惯后是可以满足出图问题，只是得改作图习惯。

zhangli019 · 发表于 2014-1-20 12:20

呵呵，现在接触的图纸还没这么多

wsz100 · 发表于 2014-4-4 09:32

回复 125# dnntso

如你所说,这些时间只好PDF来帮忙!
我就想不通,欧特克为什么在这个问题上视而不见?用户没反应?还是开发部门无法顾及?

汛茵 · 发表于 2017-3-25 10:20

Tao5574909 发表于 2009-8-3 09:00/ D) W$ x" T; S7 T7 |
哈哈!可能个人习惯的问题吧,我管理图纸的方法是将所有的图纸编号,放在一个文件夹,然后做一个电子表格,你想 ...

高手啊~运用不同的软件来~但是这样图纸上怎么显示呢？

汛茵 · 发表于 2017-3-25 10:23

虽然我曾经也苦恼过，但是毕竟做的量都不多，所以后来也没有在想过此事，楼主这样一提，倒是觉得真的很有必要知道这个页码如何编排更方便才是对的~

wtrendong · 发表于 2017-8-7 09:50

这个问题还有人关注吗？我用c#做了个工具，跟图纸集结合在一起，可以解决这个问题，可能太晚了，大家都找到方法了

xotoo · 发表于 2019-10-6 19:58

wtrendong 发表于 2017-8-7 09:50- ]( d# B W! W
这个问题还有人关注吗？我用c#做了个工具，跟图纸集结合在一起，可以解决这个问题，可能太晚了，大家都找到 ...

解决了？
希望发上来看看

这个问题桌子公司一直没有解决

		自动登录	找回密码
密码			立即注册

[求助] 图纸集的页码问题悬而未决!!(非通晓图纸集者勿入)

浏览过的版块