functions.bas

CATIA二次开发

Attribute VB_Name = "functions"
Option Explicit

'要出工程图的模型文件
Dim ModelFile As String

'视图对象变量
Dim oFrontView As DrawingView
Dim oLeftView As DrawingView
Dim oTopView As DrawingView

'是否生成左视图与顶视图的标记
Dim bLeftView As Boolean, bTopView As Boolean

'文本变量：标题 检查人 检查日期 审核 审核日期
Dim Title
Dim CheckBy, CheckDate
Dim APPR, APPRDate

'图形已生成的标记
Public bDrawingHasGened As Boolean

'文件已选择的标记
Public bFileSelected As Boolean

'设置参数
Sub InitVars()

    With Form1
        
        ModelFile = .txtFile.Text
        If Dir(ModelFile) = "" Then
            MsgBox "文件不存在！", vbCritical
            End
        End If
        
        bLeftView = .chkLeftView.Value
        bTopView = .chkTopView.Value
        
        Title = .txtTitle.Text
        CheckBy = .txtCheckBy.Text
        CheckDate = .txtCheckDate.Text
        APPR = .txtAPPR.Text
        APPRDate = .txtAPPRDate.Text
        
    End With
    
End Sub

'创建工程图并调用其它过程
Sub GenNewSheet()
    
    '新建工程图文档
    InitCATIADrawing True
    
    '获取当前活动页面
    Dim oSheets As DrawingSheets, oSheet As DrawingSheet
    Set oSheets = oDrawingDoc.Sheets
    Set oSheet = oSheets.ActiveSheet
    
    '设置页面
    oDrawingDoc.Standard = catISO
    oSheet.PaperSize = catPaperA1
    oSheet.[Scale] = 1
    oSheet.Orientation = catPaperLandscape
    
    '缩放窗口
    CATIA.ActiveWindow.ActiveViewer.Reframe
    
    '插入图框，生成视图
    InsertTitleBlock
    GenViews
    
    '更新文件
    oDrawingDoc.Update
    
    '设置图形已生成的标记
    bDrawingHasGened = True

End Sub

'插入图框
Sub InsertTitleBlock()
    
    '定义图框文件变量及路径
    Dim TitleBlockFile As String, oTitleBlockDrawing As DrawingDocument
    TitleBlockFile = App.Path & "\A1.CATDrawing"
    
    '检测图框文件是否存在
    If Dir(TitleBlockFile) = "" Then
        MsgBox "缺少图框文件！！", vbCritical
        End
    End If
    
    '打开图框文件，
    '为避免和已经打开的文件冲突，这里不使用模板里的函数
    On Error Resume Next
    Set CATIA = GetObject(, "CATIA.Application")
    If Err.Number <> 0 Then
      Set CATIA = CreateObject("CATIA.Application")
      CATIA.Visible = True
    End If
    CATIA.Documents.Open (TitleBlockFile)
    On Error GoTo 0
    
    '获取图框文件句柄
    Set oTitleBlockDrawing = CATIA.ActiveDocument
    
    '搜索图框中所有的几何图形和文本并复制到剪贴板
    oTitleBlockDrawing.Selection.Clear
    oTitleBlockDrawing.Selection.Search ("类型=几何图形+类型=文本,all")
    oTitleBlockDrawing.Selection.Copy
    
    '激活要粘贴的文件
    oDrawingDoc.Activate
    
    '将视图切换到背景视图从剪粘板粘贴数据，再切换回工作视图
    CATIA.StartCommand "背景"
    CATIA.StartCommand "粘贴"
    CATIA.StartCommand "工作视图"
    
    '关闭图框文件
    oTitleBlockDrawing.Close

End Sub

'创建视图
Sub GenViews()

    '获取当前的活动页面
    Dim oSheet As DrawingSheet
    Set oSheet = oDrawingDoc.Sheets.ActiveSheet

    '在此页面中添加一个视图，名称自动生成
    Set oFrontView = oSheet.Views.Add("AutomaticNaming")

    '获取视图的生成行为属性
    Dim oFrontViewGB As DrawingViewGenerativeBehavior
    Set oFrontViewGB = oFrontView.GenerativeBehavior

    '定义主视图关联的零件文档
    InitCATIAPart False, ModelFile
    oFrontViewGB.Document = oPart
    oPartDoc.Close
    oDrawingDoc.Activate

    '定义该视图为主视图，这里定义零件文档的YZ平面为参考面（Y轴负方向）
    oFrontViewGB.DefineFrontView 0, -1, 0, 1, 0, 0
        
    '获取主视图的零件文件链接
    Dim oFrontViewLinks As DrawingViewGenerativeLinks
    Set oFrontViewLinks = oFrontView.GenerativeLinks
    
    '定义视图在页面中的位置
    oFrontView.x = 250
    oFrontView.y = 425
    
    '更新主视图
    oFrontViewGB.Update
    
    '用户选择生成左视图
    If bLeftView Then
        
        '在页面中添加一个视图，名称自动生成
        Set oLeftView = oSheet.Views.Add("AutomaticNaming")
        
        '获取视图的生成行为属性
        Dim oLeftViewGB As DrawingViewGenerativeBehavior
        Set oLeftViewGB = oLeftView.GenerativeBehavior
        
        '把此页面定义为左视图
        oLeftViewGB.DefineProjectionView oFrontViewGB, catLeftView
        
        '获取左视图的零件文件链接
        Dim oLeftViewLinks As DrawingViewGenerativeLinks
        Set oLeftViewLinks = oLeftView.GenerativeLinks
        
        '将主视图的零件文件链接复制到左视图
        oFrontViewLinks.CopyLinksTo oLeftViewLinks
        
        '定义左视图在页面中的位置
        oLeftView.x = 550
        oLeftView.y = 425
        
        '将左视图与主视图对齐
        oLeftView.ReferenceView = oFrontView
        oLeftView.AlignedWithReferenceView
    
        '更新视图
        oLeftViewGB.Update
        
    End If
    
    '用户选择生成左视图，且左视图未生成
    If bTopView Then
        
        '在页面中添加一个视图，名称自动生成
        Set oTopView = oSheet.Views.Add("AutomaticNaming")
        
        '获取视图的生成行为属性
        Dim oTopViewGB As DrawingViewGenerativeBehavior
        Set oTopViewGB = oTopView.GenerativeBehavior
        
        '把此页面定义为顶视图
        oTopViewGB.DefineProjectionView oFrontViewGB, catTopView
    
        '获取顶视图的零件文件链接
        Dim oTopViewLinks As DrawingViewGenerativeLinks
        Set oTopViewLinks = oTopView.GenerativeLinks
        
        '将主视图的零件文件链接复制到顶视图
        oFrontViewLinks.CopyLinksTo oTopViewLinks
        
        '定义顶视图在页面中的位置
        oTopView.x = 250
        oTopView.y = 200
        
        '将顶视图与主视图对齐
        oTopView.ReferenceView = oFrontView
        oTopView.AlignedWithReferenceView
    
        '更新视图
        oTopViewGB.Update
        
    End If

End Sub

'修改视图
Sub ModifyViews()
    
    '获取当前的活动页面
    Dim oSheet As DrawingSheet
    Set oSheet = oDrawingDoc.Sheets.ActiveSheet
    
    '获取主视图的生成行为属性
    Dim oFrontViewGB As DrawingViewGenerativeBehavior
    Set oFrontViewGB = oFrontView.GenerativeBehavior
    
    '获取主视图的零件文件链接
    Dim oFrontViewLinks As DrawingViewGenerativeLinks
    Set oFrontViewLinks = oFrontView.GenerativeLinks
    
    '用户选择生成左视图，且左视图未生成
    If bLeftView And (oLeftView Is Nothing) Then
        
        '在页面中添加一个视图，名称自动生成
        Set oLeftView = oSheet.Views.Add("AutomaticNaming")
        
        '获取视图的生成行为属性
        Dim oLeftViewGB As DrawingViewGenerativeBehavior
        Set oLeftViewGB = oLeftView.GenerativeBehavior
        
        '把此页面定义为左视图
        oLeftViewGB.DefineProjectionView oFrontViewGB, catLeftView
        
        '获取左视图的零件文件链接
        Dim oLeftViewLinks As DrawingViewGenerativeLinks
        Set oLeftViewLinks = oLeftView.GenerativeLinks
        
        '将主视图的零件文件链接复制到左视图
        oFrontViewLinks.CopyLinksTo oLeftViewLinks
        
        '定义左视图在页面中的位置
        oLeftView.x = 550
        oLeftView.y = 425
        
        '将左视图与主视图对齐
        oLeftView.ReferenceView = oFrontView
        oLeftView.AlignedWithReferenceView
    
        '更新视图
        oLeftViewGB.Update
    
    ElseIf (Not bLeftView) And (Not oLeftView Is Nothing) Then
        
        '若用户取消左视图的生成，且左视图已生成，则删除左视图
        oSheet.Views.Remove oLeftView.Name
        Set oLeftView = Nothing
    
    End If
    
    '用户选择生成顶视图，且顶视图未生成
    If bTopView And (oTopView Is Nothing) Then
        
        '在页面中添加一个视图，名称自动生成
        Set oTopView = oSheet.Views.Add("AutomaticNaming")
        
        '获取视图的生成行为属性
        Dim oTopViewGB As DrawingViewGenerativeBehavior
        Set oTopViewGB = oTopView.GenerativeBehavior
        
        '把此页面定义为顶视图
        oTopViewGB.DefineProjectionView oFrontViewGB, catTopView
    
        '获取顶视图的零件文件链接
        Dim oTopViewLinks As DrawingViewGenerativeLinks
        Set oTopViewLinks = oTopView.GenerativeLinks
        
        '将主视图的零件文件链接复制到顶视图
        oFrontViewLinks.CopyLinksTo oTopViewLinks
        
        '定义顶视图在页面中的位置
        oTopView.x = 250
        oTopView.y = 200
        
        '将顶视图与主视图对齐
        oTopView.ReferenceView = oFrontView
        oTopView.AlignedWithReferenceView
    
        '更新视图
        oTopViewGB.Update
    
    ElseIf (Not bTopView) And (Not oTopView Is Nothing) Then
        
        '若用户取消顶视图的生成，且顶视图已生成，则删除顶视图
        oSheet.Views.Remove oTopView.Name
        Set oTopView = Nothing
    
    End If
    
End Sub

'修改图框中的文字
Sub ModifyText()
    
    '设定错误控制
    On Error Resume Next
    
    '将视图切换到背景视图
    CATIA.StartCommand "背景"
    
    '获取当前的活动页面
    Dim oSheet As DrawingSheet
    Set oSheet = oDrawingDoc.Sheets.ActiveSheet

    '获取当前活动视图
    Dim MyView As DrawingView
    Set MyView = oSheet.Views.ActiveView
    
    '定义文字变量
    Dim oText As DrawingText
    
    '修改 图框标题
    Set oText = MyView.Texts.GetItem("Title")
    oText.Text = Title
    
    '修改 检查人
    Set oText = MyView.Texts.GetItem("CheckBy")
    oText.Text = CheckBy
    
    '修改 检查日期
    Set oText = MyView.Texts.GetItem("CheckDate")
    oText.Text = CheckDate
    
    '修改 审核人
    Set oText = MyView.Texts.GetItem("APPR")
    oText.Text = APPR
    
    '修改 审核日期
    Set oText = MyView.Texts.GetItem("APPRDate")
    oText.Text = APPRDate
    
    '将视图切换回工作视图
    CATIA.StartCommand "工作视图"
    
    '取消错误控制
    On Error GoTo 0
    
    '更新文档
    oDrawingDoc.Update
    
End Sub