张金龙的博客分享 http://blog.sciencenet.cn/u/zjlcas 物种适应性、分布与进化

博文

从植物采集记录生成标本记录标签

已有 6241 次阅读 2013-1-31 23:30 |个人分类:软件介绍|系统分类:科研笔记|关键词:学者| EXCEL, VBA, 采集标签, 采集记录, 植物标本

请参阅

http://blog.sciencenet.cn/blog-255662-849868.html

https://github.com/helixcn/herblabel

使用 herblabel程序包生成植物标本采集标签。


 


早在2006年, 一起和同门的陈彬博士在云南出野外时, 陈博士就提供了一个打印植物采集标签的Excel小程序。 因为我当时完全不懂编程, 觉得很神奇, 程序虽然很小,但是确实提供了很多方便。

进入嘉道理农场工作以来, 我的工作包括采集标本。 从采集记录快速生成采集标签的需求又一次摆在我面前。 但是陈彬博士提供的excel程序各部分都是中文, 但是我需要输入英文, 标签的格式也要进行相应的调整。 基于他提供的VBA程序, 我对VBA的源代码进行了修改, 调整了输出标签的格式,以及字体, 每一行的大小, 以及插入分隔符的位置等。

实现的功能
输入 在sheet1中按照要求相应的采集信息, 执行本命令, 例如用按钮关联,在sheet2中就可以生成固定的标签。

以下是Excel VBA中的源代码。 供感兴趣的读者参考, 并欢迎提出宝贵意见。
''#########################################################################

''########## This macro was developed Dr. JinlongZhang  base on ##########

''################# a  VBA macro by Dr.  Bin Chen #########################

''################# Email : jinlongzhang01@gmail.com ####################

''#########################  30/01/2013###################################

''#########################################################################

 

Dim a, b, c, d,e, f, g As Integer  'Definition of the variables

'Maximum Number of labels can be created

'b

Sheet2.Columns.Clear

Sheet2.ResetAllPageBreaks

Sheet2.DisplayPageBreaks = False

 

c = 1                               '

d = 0

For a = 2 To 50000

   If Sheet1.Cells(a, 1) = "" Then

      MsgBox "Please find the labels in Sheet 2"

       Exit For

   Else

       g =Sheet1.Cells(a, 16)   ' Numberof copies for one collection number

       For b = 1 To g

            If d > 1 And (d Mod 8 = 0 Or d Mod 8 = 1) Then 'Ajustingthe margins, and number of labels per page.

              f = 13

            Else

              f = 14

            End If

 

        If d > 1 And (d Mod 2 = 0) Then

           c = c + f

       End If

           e = (d + 1) Mod 2

If e = 1 Then

 

  Sheet2.Cells(c, 1) = TextBox1.Text

  Sheet2.Cells(c + 1, 1) = TextBox2.Text

  Sheet2.Cells(c + 2, 1) = Sheet1.Cells(a, 4) '"Species: "

  Sheet2.Cells(c + 3, 1) = Sheet1.Cells(a, 5) ' "Infraspecies: "

  Sheet2.Cells(c + 4, 1) = "Family: " +Sheet1.Cells(a, 8)

  Sheet2.Cells(c + 5, 1) = "Local Name: " +Sheet1.Cells(a, 6)

  Sheet2.Cells(c + 6, 1) = "Field Note: " +Sheet1.Cells(a, 9)

  Sheet2.Cells(c + 7, 1) = "Locality: " +Sheet1.Cells(a, 17)

  Sheet2.Cells(c + 8, 1) = "Lon/Lat/Alt: " +Sheet1.Cells(a, 18) + "/" +Sheet1.Cells(a, 19) + "/" +Sheet1.Cells(a, 20) + "m"

  Sheet2.Cells(c + 9, 1) = "Col. & Num: " + Sheet1.Cells(a, 2) + " " +Sheet1.Cells(a, 1)

  Sheet2.Cells(c + 10, 1) = "Date Col.: " +Sheet1.Cells(a, 3)

  Sheet2.Cells(c + 11, 1) = "Det. & Date: " + Sheet1.Cells(a, 24) + "/" +Sheet1.Cells(a, 25)

  Sheet2.Cells(c + 12, 1) = "Note: " +Sheet1.Cells(a, 13)

 

   With Sheet2  'applicaton    ' Adjusting the display of the text

       'Set height for rows

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).RowHeight = 12

       'Set width for columns

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).ColumnWidth = 42

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).Font.Name = "Arial"

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).Font.Size = 11       'Size

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).HorizontalAlignment = xlGeneral

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).VerticalAlignment = xlCenter

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).WrapText = False

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).Orientation = 0

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).AddIndent = False

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).IndentLevel = 0

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).ShrinkToFit = True

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).ReadingOrder = xlContext

       .Range(.Cells(c,1), .Cells(c+ 12, 1)).MergeCells = False

   End With

 

   With Sheet2.Cells(c, 1)  'Adjusting the Title, right

       .Font.Name= "Arial" 'Font

       .Font.Size= 12     'Size

       .Font.Bold= True   'Alignment

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .WrapText= False

       .Orientation= 0

       .AddIndent= False

       .IndentLevel= 0

       .ShrinkToFit= True

       .ReadingOrder= xlContext

       .MergeCells= False

   End With

   

   With Sheet2.Cells(c + 1, 1)   ' Formatthe subtitle

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .Font.Name= "Times New Roman" 'Font

       .Font.Size= 12     'Size

   End With

ElseIf e = 0 Then

 

  Sheet2.Cells(c, 2) = TextBox1.Text          'Title

  Sheet2.Cells(c + 1, 2) = TextBox2.Text      'Subtitle

  Sheet2.Cells(c + 2, 2) = Sheet1.Cells(a, 4) '"Species: "

  Sheet2.Cells(c + 3, 2) = Sheet1.Cells(a, 5) ' "Infraspecies: "

  Sheet2.Cells(c + 4, 2) = "Family: " +Sheet1.Cells(a, 8)

  Sheet2.Cells(c + 5, 2) = "Local Name: " +Sheet1.Cells(a, 6)

  Sheet2.Cells(c + 6, 2) = "Field Note: " +Sheet1.Cells(a, 9)

  Sheet2.Cells(c + 7, 2) = "Locality: " +Sheet1.Cells(a, 17)

  Sheet2.Cells(c + 8, 2) = "Lon/Lat/Alt: " +Sheet1.Cells(a, 18) + "/" +Sheet1.Cells(a, 19) + "/" +Sheet1.Cells(a, 20) + "m"

  Sheet2.Cells(c + 9, 2) = "Col. & Num: " + Sheet1.Cells(a, 2) + " " +Sheet1.Cells(a, 1)

  Sheet2.Cells(c + 10, 2) = "Date Col.: " +Sheet1.Cells(a, 3)

  Sheet2.Cells(c + 11, 2) = "Det. & Date: " + Sheet1.Cells(a, 24) + "/" +Sheet1.Cells(a, 25)

  Sheet2.Cells(c + 12, 2) = "Note: " +Sheet1.Cells(a, 13)

   

   With Sheet2  'applicaton

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).RowHeight = 12         'Setheight for rows

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).ColumnWidth = 42       'Setwidth for columns

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).Font.Name = "Arial"

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).Font.Size = 11          'Size

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).HorizontalAlignment = xlGeneral

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).VerticalAlignment = xlCenter

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).WrapText = False

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).Orientation = 0

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).AddIndent = False

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).IndentLevel = 0

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).ShrinkToFit = True

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).ReadingOrder = xlContext

       .Range(.Cells(c,2), .Cells(c+ 12, 2)).MergeCells = False

   End With

   

 

   With Sheet2.Cells(c, 2)  'Adjusting the label, right

       .Font.Name= "Arial" 'Font

       .Font.Size= 12     'Size

       .Font.Bold= True   'Alignment

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .WrapText= False

       .Orientation= 0

       .AddIndent= False

       .IndentLevel= 0

       .ShrinkToFit= True

       .ReadingOrder= xlContext

       .MergeCells= False

   End With

   

   With Sheet2.Cells(c + 1, 2)            'Formatthe subtitle

       .HorizontalAlignment= xlCenter

       .VerticalAlignment= xlCenter

       .Font.Name= "Times New Roman"   'Font

       .Font.Size= 12                  'Size

   End With

   

  End If

 d =d + 1

 Next b

 

   If f = 13 And c > 1 Then

                      Sheet2.HPageBreaks.AddBefore:=Sheet2.Cells(c, 1)

   End If

 

 End If

Next a

 

   With Sheet2.PageSetup

       .LeftMargin= Application.InchesToPoints(0.5)

       .RightMargin= Application.InchesToPoints(0.5)

       .TopMargin= Application.InchesToPoints(0.5)

       .BottomMargin= Application.InchesToPoints(0.5)

       .HeaderMargin= Application.InchesToPoints(0.5)

       .FooterMargin= Application.InchesToPoints(0.5)

      .PrintHeadings = False

       .PrintGridlines= False

       .PrintNotes= False

       .CenterHorizontally= False

       .CenterVertically= False

       .Orientation= xlPortrait

       .Draft= False

       .PaperSize= xlPaperA4                  ' xlPaperA4:A4

       .FirstPageNumber= xlAutomatic

       .Order= xlDownThenOver

       .BlackAndWhite= False

       .Zoom= 100

       .FitToPagesWide= 1

       .FitToPagesTall= 1

       .PrintErrors= xlPrintErrorsDisplayed

       End With

Sheet2.PrintPreview

 



https://m.sciencenet.cn/blog-255662-658384.html

上一篇:两棵进化树一致性的校对
下一篇:瑞典纪事: 实验记录DNA提取/PCR/毛细管电泳

0

该博文允许注册用户评论 请点击登录 评论 (3 个评论)

数据加载中...
扫一扫,分享此博文

Archiver|手机版|科学网 ( 京ICP备07017567号-12 )

GMT+8, 2024-3-29 20:41

Powered by ScienceNet.cn

Copyright © 2007- 中国科学报社

返回顶部