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

请参阅

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

https://github.com/helixcn/herblabel

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

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

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

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

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
 ''#########################################################################
''########## 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 'A justing the 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