如何实现家谱垂丝图(吊线图)

付谦

现在的树是横式的,但家谱习惯是垂丝图(或叫吊线图),也不是宝塔图,在网上都是些手动制作垂丝图(或叫吊线图)操作,几万记录要做完要多长时间,还要人工校对,一旦有变动,前功尽失,本人知识太少,因此向各位大师们恳求自动生成家谱垂丝图(吊线图)代码,无论是用窗体.报表或WORD,EXCEL都行,只要能达到附件上注的效果.谢谢!

付谦

能有这样效果也行,可能代码简单些:---------------------------------------------------------------------------------------------------------------------　
一世　　　  二世　　　　三世　   　四世　　五世　.........　　　　　　　　　　　八世
杨一益 ──ο 杨子吕 ─┯─ο 杨银　
                               ├─ ο 杨发 ──ο 杨式　................
　　　　　　　　　 ├─ ο 杨伟 ──ο 杨再　................

aslxt

吊线图就用visio吧.如果仅仅是打印,比较简单,根据世次/排行确定图形的位置,再根据上下级关系确定连接线的走向,姓名变为图形的文字,就差不多了.如果要在visio上显示成员的更多信息(生/居/殁/葬等等),最好是定义好形状及其形状数据,再定义绘图模板,然后导出就可以了.当然,还要学习一下visio的vba(不是很难,可录制宏参考).

aslxt

如图

aslxt

Const mm As Double = 1 / 25.4
Const 行距 = 10 * mm
Const 列距 = 15 * mm
Const X0 = 10 * mm
Const Y0 = 280 * mm

Private Sub Command1_Click()
    Call 开始
End Sub


'***********************************************
'从根节点绘制形状,调用递归过程一直到所有的子孙节点都绘制完成.
'如果族人成员太多,需要分级分页绘制,就需要自己添加每页绘制的代数,每页的开始节点,以及如何循环添加visio的页等
'***********************************************
Sub 开始()    '加载根节点
'要引用  Microsoft Visio 12.0 Type Library  '我这里使用的是Visio2007
    Dim Rec As New ADODB.Recordset, i, Y
    Dim vs As New Visio.Application, vsoDoc As Visio.Document, shp As Visio.Shape

    Rec.Open "select * from 族人信息 where nz(承上码,0)=0  order by 族人代码", Conn, adOpenStatic, adLockReadOnly
    Set vsoDoc = vs.Documents.AddEx("basicd_m.vst", visMSDefault, 0)    '打开visio程序并基于"basicd_m.vst"模板新建文件
    For i = 1 To Rec.RecordCount
        If i > 1 Then    '把"BASIC_M.VSS"模具的"Rectangle"形状绘制到页面上
            Set shp = vsoDoc.Pages(1).Drop(vs.Documents.Item("BASIC_M.VSS").Masters.ItemU("Rectangle"), X0, GetMinY(vsoDoc) - 行距)
        Else
            Set shp = vsoDoc.Pages(1).Drop(vs.Documents.Item("BASIC_M.VSS").Masters.ItemU("Rectangle"), X0, Y0)
        End If
        With shp    '设置形状属性
            .CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "10 mm"    '形状宽度
            .CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "5 mm"    '形状高度
            .CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "6 pt"    '形状字号
            .Name = CStr(Rec!族人代码)    '形状名称
            .Characters.Text = CStr(Rec!姓名)    '形状文本
        End With
        '记录集有按照树形的上下顺序排序的字段,就不需要递归了
        递归 Rec!族人代码, vsoDoc    '调用递归过程完成根节点下的所有节点
        Rec.MoveNext
    Next i
    '添加首行的世代信息
    Rec.MoveFirst
    Dim minD, maxD
    minD = Rec!世代
    maxD = DMax("世代", "族人信息")
    For i = minD To maxD
        Set shp = vsoDoc.Pages(1).Drop(vsoDoc.Application.Documents.Item("BASIC_M.VSS").Masters.ItemU("Rectangle"), X0 + (i - minD) * 列距, Y0 + 行距)
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "10 mm"
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "5 mm"
        shp.CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "6 pt"
        shp.Characters.Text = CStr("第" & i & "世")
    Next i
End Sub

Sub 递归(BM, vsoDoc As Visio.Document)
    Dim Rec As New ADODB.Recordset, i, N, X, Y
    Dim shp As Visio.Shape, vsoCellA As Visio.Cell, vsoCellB As Visio.Cell, vsoChar As Visio.Characters
    Dim PX, PY, BX, B  '父亲/哥哥的位置
    PX = vsoDoc.Pages(1).Shapes(CStr(BM)).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX)
    PY = vsoDoc.Pages(1).Shapes(CStr(BM)).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY)
    Rec.Open "select * from 族人信息 WHERE 承上码=" & BM & "  order by 族人代码", Conn, adOpenStatic, adLockReadOnly
    For i = 1 To Rec.RecordCount
        N = DCount("*", "族人信息", "承上码=" & Rec!承上码 & " and 族人代码<" & Rec!族人代码)    '成员的哥哥的数量
        If DCount("*", "族人信息", "承上码=" & Rec!族人代码) = 0 Then    '成员的后代数量
            B = DMax("族人代码", "族人信息", "承上码=" & Rec!承上码 & " and 族人代码<" & Rec!族人代码)    '最小的哥哥的编号
            If Nz(B, 0) > 0 Then
                Y = vsoDoc.Pages(1).Shapes(CStr(B)).CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY) - 行距    '以最小的哥哥的Y坐标为基准,再偏移一个行距
            Else
                Y = PY    '以父亲的Y坐标为基准
            End If
        Else
            If N = 0 Then
                Y = PY
            Else
                Y = GetMinY(vsoDoc) - 行距
            End If
        End If

        X = PX + 列距
        Set shp = vsoDoc.Pages(1).Drop(vsoDoc.Application.Documents.Item("BASIC_M.VSS").Masters.ItemU("Rectangle"), X, Y)
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "10 mm"
        shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "5 mm"
        shp.CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "6 pt"
        shp.Name = CStr(Rec!族人代码)
        shp.Characters.Text = CStr(Rec!姓名)

        If Nz(Rec!承上码, 0) > 0 Then
            '添加连接线
            Set shp = vsoDoc.Pages(1).Drop(vsoDoc.Application.ConnectorToolDataObject, 1.968504, 9.055118)
            shp.Name = "L" & CStr(Rec!族人代码)
            '连接上级
            Set vsoCellA = vsoDoc.Pages(1).Shapes("L" & CStr(Rec!族人代码)).CellsU("BeginX")
            Set vsoCellB = vsoDoc.Pages(1).Shapes(CStr(Rec!承上码)).CellsSRC(7, 1, 0)
            vsoCellA.GlueTo vsoCellB
            '连接下级
            Set vsoCellA = vsoDoc.Pages(1).Shapes("L" & CStr(Rec!族人代码)).CellsU("EndX")
            Set vsoCellB = vsoDoc.Pages(1).Shapes(CStr(Rec!族人代码)).CellsSRC(7, 3, 0)
            vsoCellA.GlueTo vsoCellB
        End If
        递归 Rec!族人代码, vsoDoc
        Rec.MoveNext
    Next i
End Sub

Function GetMinY(vsoDoc As Visio.Document) As Variant    '获得页面上所有形状的最小的Y坐标
    Dim shp As Visio.Shape, Y As Double
    Y = Y0
    For Each shp In vsoDoc.Pages(1).Shapes
        If IsNumeric(shp.Name) Then
            If shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY) < Y Then
                Y = shp.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY)
            End If
        End If
    Next
    GetMinY = Y
End Function

accben

access结合visio，厉害了！

付谦

ASLXT大师真厉害,知识广,乐助人!
代码经运行好用,虽然过去没有接触visio,抓紧学习,在大师的基础上再细化一下,完全满足所需.

aslxt

付谦 发表于 2021-4-26 16:05
ASLXT大师真厉害,知识广,乐助人!
代码经运行好用,虽然过去没有接触visio,抓紧学习,在大师的基础上再细化一 ...

惭愧,我不是大师,只是恰好在不久前做了同样的东西而已.

付谦

大师:
　　发现一个问题,按条件只有8世,但有时出现18世,不知从何而来,查这次的数据源也只有8世,多的是过去曾使用过的数据,承上码在8世内.我分析是visio系统或内存中保存有永久数据,只要对上自动连接上了.我不知系统或内存数据如何清除.加了 Set Rec = Nothing不管用,请教如何处理?

aslxt

应该与visio没有关系:
1,看看第九世的承上码是不是跟visio的连接线一致,你可以把代码/承上码/姓名一起输出到visio,便于检查逻辑
2,在treeview中检查是否符合逻辑,
2,看看有没有公共变量混进了递归过程
3,看看父子关系是不是有错误
如有必要,可以加我QQ:853156456