Access911.net   |   a9BBS   |   OTaA System  
  搜索文章:  
Access911欢迎您光临  
   主页      上传      繁體版       论坛     
设为首页  |  加入收藏   
  
你现在的位置:文章索引 -> 文章分类 -> OA  
 首页|  近日更新|  下载  |  文章索引  |  搜索|  术语|  承接工程|  
 
系统正在加载内容,请耐心等待...
 
 查询
 窗体
 报表
 
 
 VBA
 函数
 ADO/DAO/ADO.NET
 API
 ADP
 安全
 发布
 OA
 ASP/ASP.NET
 其他语言
 控件
 DELPHI
 C#/.Net
 本站
 其他
 小例程
 常用软件
 参考文档
 业主作品
 网友大作
 
 
友情链接
 access911.net
 
访问人次
 1701856
 
站长 E-Mail
 net911@sina.com
 access911@gmail.com
 
RSS 订阅

显示附加信息 >>>

如何在Excel2003的工作表中加入标尺功能,以厘米为单位?

作者:cg1  摘自:access911.net  :cg1  更新日期:2011-12-12  浏览人次:

 

问题:

如何在Excel2003的工作表中加入标尺功能,以厘米为单位?
Excel 2010 中本身就有标尺功能,EXCEL 2003 中如何加入呢?

 

回答:

Sub MakeRuler_cm()
'以厘米为单位,在sheet中创建一个标尺,而且该标尺不是图片,是形状组合。    
    Const Ruler_Width As Double = 17    'Width 17 cm
    Const Ruler_Height As Double = 17   'Height 17 cm
    
    Dim i As Long
    Dim l As Long
    Dim x As Long
    Dim y As Long
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim ws2 As Worksheet
    Dim x2 As Double
    Dim y2 As Double
    Dim s1 As Object
    Dim s2 As Object
    Dim dblCentimetersToPointsRate As Double
    Dim blnCurrentScreenUpdating As Boolean
    
    dblCentimetersToPointsRate = Application.CentimetersToPoints(1)
    
    
    x = Ruler_Width * 10
    y = Ruler_Height * 10
    blnCurrentScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
    
    Set ws = ActiveSheet
    Set wb = Application.Workbooks.Add
    Set ws2 = wb.Sheets.Add
    ActiveSheet.Lines.Add 0, 0, 3 * x, 0
    For i = 1 To x
        If i Mod 10 = 0 Then
            l = 5
        Else
            If i Mod 5 = 0 Then
                l = 4
            Else
                l = 3
            End If
        End If
        'ActiveSheet.Lines.Add 3 * i, 0, 3 * i, 3 * l
        ActiveSheet.Lines.Add dblCentimetersToPointsRate * i * 0.1, 0, dblCentimetersToPointsRate * i * 0.1, 3 * l
        'ActiveSheet.Lines.Add Application.CentimetersToPoints(i * 0.1), 0, Application.CentimetersToPoints(i * 0.1), 3 * l
    Next
    ActiveSheet.Lines.Add 0, 0, 0, 3 * y
    For i = 1 To y
        If i Mod 10 = 0 Then
            l = 5
        Else
            If i Mod 5 = 0 Then
                l = 4
            Else
                l = 3
            End If
        End If
        ActiveSheet.Lines.Add 0, dblCentimetersToPointsRate * 0.1 * i, 3 * l, dblCentimetersToPointsRate * 0.1 * i
        'ActiveSheet.Lines.Add 0, Application.CentimetersToPoints(i * 0.1), 3 * l, Application.CentimetersToPoints(i * 0.1)
    Next
    ActiveSheet.Lines.Border.ColorIndex = 55
    
    For i = 10 To x - 1 Step 10
        With ActiveSheet.TextBoxes.Add(dblCentimetersToPointsRate * 0.1 * i - 9, 3 * 5, 18, 12)
        'With ActiveSheet.TextBoxes.Add(Application.CentimetersToPoints(i * 0.1) - 9, 3 * 5, 18, 12)
            .Text = Format(i \ 10, "!@@")
            
            .Font.Size = 9
            .Font.ColorIndex = 55
            .Border.ColorIndex = xlNone
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Interior.ColorIndex = xlNone
        End With
    Next
    For i = 10 To y - 1 Step 10
        With ActiveSheet.TextBoxes.Add(3 * 5, dblCentimetersToPointsRate * 0.1 * i - 9, 12, 18)
        'With ActiveSheet.TextBoxes.Add(3 * 5.5, Application.CentimetersToPoints(i * 0.1) - 9, 12, 18)
            .Orientation = xlDownward
            .Text = Format(i \ 10, "!@@")
            
            .Font.Size = 9
            .Font.ColorIndex = 55
            .Border.ColorIndex = xlNone
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Interior.ColorIndex = xlNone
        End With
    Next

    '这段代码是我自己加上的
    Set s1 = ActiveSheet.Lines.Group
    Set s2 = ActiveSheet.TextBoxes.Group
    Debug.Print s2.Name, s1.Name
    ActiveSheet.Shapes.Range(Array(s1.Name, s2.Name)).Group.Copy
    ws.Activate
    'ws.PasteSpecial      'Format:="Picture (PNG)"  '也可以粘贴为图片格式,不过图片格式选取起来不方便。
    ws.Range("a1").Select
    ws.Paste
    Selection.Name = "TestGroupShapes"
    wb.Close False
    '自己加的结束
    
    'With ActiveSheet.TextBoxes
    '    .Font.Size = 9
    '    .Font.ColorIndex = 55
    '    .Border.ColorIndex = xlNone
    '    ''非常奇怪,如果对象数量多了,会导致 .HorizontalAlignment 等3个属性无法设置。
    '    '.HorizontalAlignment = xlCenter
    '    '.VerticalAlignment = xlCenter
    '    '.Interior.ColorIndex = xlNone
    'End With

     Application.ScreenUpdating = blnCurrentScreenUpdating
End Sub


 

本站文章旨在为该问题提供解决思路及关键性代码,并不能完成应该由网友自己完成的所有工作,请网友在仔细看文章并理解思路的基础上举一反三、灵活运用。

access911.net 原创文章,作者本人对文章保留一切权利。
如需转载必须征得作者同意并注明本站链接

 

 
相关文章
     没有手动相关文章
     如何制作复杂报表——利用Excel输出复杂报表
     新手来看:如何将数据表导出备份到excel表格
     新手来看:我是否可以将Excel数据导入?
     新手来看:excel中怎么编程获取单元格字符颜色、背景、批注?
     一个将数据导出到EXCEL的存储过程
     如何将整个 MDB 中所有的表全部导出到一个 XLS 中去?
     如何在导出表到EXCEL时让用户随意选择字段?
     Excel当有多列合并单元格时如何只选中其中一列?
     Excel中如何返回差集
     如何在EXCEL中截图,并将图片保存为GIF或者JPG格式
 
评论
     查看或发表更多的评论,请单击这里。
 
 
 
 
 
   
  Access911.net   |   a9BBS   |   OTaA System   |
建站日期:2000年4月2日  |  设计施工:陈格 ( access911 & cg1 )
 Copyright © 2000 - 2003 COMET, 陈格 保留所有权利