form1.frm

自己设计的表格自动生成器

VERSION 5.00
Begin VB.Form Frm_Rose 
   Caption         =   "幸福像花儿一样"
   ClientHeight    =   4605
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   5145
   LinkTopic       =   "Form1"
   ScaleHeight     =   4605
   ScaleWidth      =   5145
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   " 重新排序"
      Height          =   375
      Left            =   3600
      TabIndex        =   14
      Top             =   3720
      Width           =   1095
   End
   Begin VB.ListBox List2 
      Height          =   1140
      Left            =   3000
      TabIndex        =   13
      Top             =   2160
      Width           =   1815
   End
   Begin VB.CommandButton Cacel 
      Caption         =   "退出"
      Height          =   375
      Left            =   3720
      TabIndex        =   12
      Top             =   120
      Width           =   1095
   End
   Begin VB.TextBox Text4 
      Height          =   375
      Left            =   960
      TabIndex        =   9
      Text            =   "Text4"
      Top             =   720
      Width           =   1575
   End
   Begin VB.CommandButton Command3 
      Caption         =   "生成表格"
      Height          =   375
      Left            =   2040
      TabIndex        =   5
      Top             =   3720
      Width           =   1095
   End
   Begin VB.ListBox List1 
      Height          =   1140
      Left            =   3000
      TabIndex        =   4
      Top             =   720
      Width           =   1815
   End
   Begin VB.TextBox Text3 
      Height          =   375
      Left            =   960
      TabIndex        =   3
      Text            =   "Text3"
      Top             =   2880
      Width           =   1575
   End
   Begin VB.CommandButton Command2 
      Caption         =   "生成内容"
      Height          =   375
      Left            =   480
      TabIndex        =   2
      Top             =   3720
      Width           =   1095
   End
   Begin VB.TextBox Text2 
      Height          =   375
      Left            =   960
      TabIndex        =   1
      Text            =   "Text2"
      Top             =   2160
      Width           =   1575
   End
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   960
      TabIndex        =   0
      Text            =   "Text1"
      Top             =   1440
      Width           =   1575
   End
   Begin VB.Label Label5 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BackStyle       =   0  'Transparent
      Caption         =   "机自动编码工具"
      ForeColor       =   &H80000002&
      Height          =   195
      Left            =   1860
      TabIndex        =   11
      Top             =   150
      Width           =   1260
   End
   Begin VB.Label Label4 
      Caption         =   "总数"
      Height          =   255
      Left            =   360
      TabIndex        =   10
      Top             =   720
      Width           =   495
   End
   Begin VB.Label Label3 
      Caption         =   "项目3"
      Height          =   255
      Left            =   360
      TabIndex        =   8
      Top             =   2880
      Width           =   495
   End
   Begin VB.Label Label2 
      Caption         =   "项目2"
      Height          =   255
      Left            =   360
      TabIndex        =   7
      Top             =   2160
      Width           =   495
   End
   Begin VB.Label label1 
      Caption         =   "项目1"
      Height          =   255
      Left            =   360
      TabIndex        =   6
      Top             =   1440
      Width           =   495
   End
End
Attribute VB_Name = "Frm_Rose"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
  Dim cell1 As String
  Dim cell2 As String
  Dim cell3 As String
  Dim n As Integer
  Dim Value_Bit(3)
  Dim Bit(3)
  Dim Value_listbox
  Dim Num_T As Integer '总表格数
  Dim List1_str_array(1 To 9000)
  Dim List2_num_array(1 To 9000)
'关闭
Private Sub Cacel_Click()
  Unload Frm_Rose
End Sub
'重新排序
Private Sub Command1_Click()
Call Re_Allign
End Sub
Private Sub Re_Allign()
List1.Clear
List2.Clear
Randomize   ' 对随机数生成器做初始化的动作。
 Ad1_in = Int((n * Rnd) + 1) '生成list1的入口序号

For i = 1 To n
X = List1_str_array(Ad1_in)
List1.AddItem X
Ad1_in = Ad1_in + 1
If Ad1_in > n Then Ad1_in = 1
Next

Randomize
Ad2_in = Int((n * Rnd) + 1) '生成list2的入口序号
For j = 1 To n
Y = List2_num_array(Ad2_in)
List2.AddItem Y
Ad2_in = Ad2_in - 1
If Ad2_in < 1 Then Ad2_in = n
Next
Call Write_File
End Sub
'填写list1、list2
Private Sub Command2_Click()
 Call GE_string
End Sub
Private Sub GE_string()
  Dim Temp_Value '编号临时变量
  Dim str_temp '字符临时变量

  Dim List_Num As Integer
  '*****提取输入项目*****
  List1.Clear
  List2.Clear
  List_Num = 0
  s = Trim(Left(Text4.Text, 1))
  
  If s = "0" Or s = "1" Or s = "2" Or s = "3" Or s = "4" Or s = "5" Or s = "6" Or s = "7" Or s = "8" Or s = "9" Then
  n = Text4.Text
  cell1 = Text1.Text
  cell2 = Text2.Text
  cell3 = Text3.Text
  Else
  MsgBox "请在总数单元中输入数字"
  Text4.Text = "0"
  End If
  
  If n Mod 40 = 0 Then
  Num_T = Abs(n / 40)
  Else
  Num_T = Abs((n - 20) / 40) + 1
  End If
  '产生不重复的字母序列
  List1_str_array(1) = Gen_Bit123()
  List1.AddItem List1_str_array(1)
  For j = 2 To n
X: str_temp = Gen_Bit123()
  For i = 1 To j - 1
  If str_temp = List1_str_array(i) Then GoTo X
  Next
  List1_str_array(j) = str_temp
  List1.AddItem str_temp
  Next
'产生不重复的数字序列
List2_num_array(1) = Ge_number()
  List2.AddItem List2_num_array(1)
  For j = 2 To n
Y: Temp_Value = Ge_number()
  For i = 1 To j - 1
  If Temp_Value = List2_num_array(i) Then GoTo Y
  Next
  List2_num_array(j) = Temp_Value
  List2.AddItem Temp_Value
  Next
End Sub
'在list中写入随即生成的数字和字母组合
Function Gen_Bit123()
  Dim Value
Z:    For i = 1 To 3
        Randomize   ' 对随机数生成器做初始化的动作。
        Bit(i) = Int((26 * Rnd) + 1)
        
        Call Gen_Letter(Bit(i), Value_Bit(i))
    Next                    '组合3个随机产生的字母，保证三个字母不同
    
        If Bit(1) = Bit(2) Or Bit(1) = Bit(3) Or Bit(2) = Bit(3) Then
        Else
        Value = Value_Bit(3) & Value_Bit(2) & Value_Bit(1)
        End If
        If Value = 空值 Then GoTo Z
        Gen_Bit123 = Value

End Function
Function Ge_number()
    '产生1000 - 9999的随机数
    Randomize
    Value_listbox = 1000 + (Int((9000 * Rnd) + 1)) Mod 9000
    Ge_number = Value_listbox
End Function

'生成随机的字母
Private Sub Gen_Letter(Bit_temp, Value)
Select Case Bit_temp
    Case 1
    Value = "A"
    Case 2
    Value = "B"
    Case 3
    Value = "C"
    Case 4
    Value = "D"
    Case 5
    Value = "E"
    Case 6
    Value = "F"
    Case 7
    Value = "G"
    Case 8
    Value = "H"
    Case 9
    Value = "I"
    Case 10
    Value = "J"
    Case 11
    Value = "K"
    Case 12
    Value = "L"
    Case 13
    Value = "M"
    Case 14
    Value = "N"
    Case 15
    Value = "O"
    Case 16
    Value = "P"
    Case 17
    Value = "Q"
    Case 18
    Value = "R"
    Case 19
    Value = "S"
    Case 20
    Value = "T"
    Case 21
    Value = "U"
    Case 22
    Value = "V"
    Case 23
    Value = "W"
    Case 24
    Value = "X"
    Case 25
    Value = "Y"
    Case 26
    Value = "Z"
    'List1.AddItem Value
    Case Else

End Select
End Sub

Private Sub Command3_Click()
 Call Write_File
End Sub
Private Sub Write_File() '(filename As String)
  'Write_Mode  1,新建  2，改写   3，增加
  Dim Write_Mode As Byte
  Dim Num_start As Long
  Num_start = 1000
 Call Ge_Table(Num_T, Num_start)
End Sub


Private Sub Ge_Table(Num_Table As Integer, Start As Long)
    Dim k As Integer
    Dim Num_List1 As Long  'list1 中的项目数
    Dim Num_List2 As Long  'list2 中的项目数
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Num_List1 = 0
    Num_List2 = 0
      Set xlApp = CreateObject("Excel.Application")
      Set xlBook = xlApp.Workbooks.Add
      Set xlSheet = xlBook.Worksheets(1)
      xlApp.Visible = True
        
      xlSheet.Cells.Font.Size = 12
    '  xlSheet.Cells.Font.Name = "宋体"
      xlSheet.Cells.HorizontalAlignment = xlCenter
      '画表格边框
      For i = 0 To Num_Table - 1
      Dim X As Integer
      Dim Y As Integer
      X = 1 + 15 * i
      Y = 12 + 15 * i
      xlSheet.Range(xlSheet.Cells(X, 1), xlSheet.Cells(Y, 16)).Borders.LineStyle = xlContinuous
      Next
      '设置列宽列高
      X = 15 * Num_Table
      xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(X, 16)).RowHeight = 22
      For i = 1 To Num_Table / 2
      Y = 30 * i - 1
      xlSheet.Range(xlSheet.Cells(Y, 1), xlSheet.Cells(Y + 1, 16)).RowHeight = 2
      Next
      '设置列宽
      xlSheet.Range("A:A").ColumnWidth = 2.5
      xlSheet.Range("B:D").ColumnWidth = 5
      xlSheet.Range("E:E").ColumnWidth = 1.25
      xlSheet.Range("F:H").ColumnWidth = 5
      xlSheet.Range("I:I").ColumnWidth = 1.25
      xlSheet.Range("J:L").ColumnWidth = 5
      xlSheet.Range("M:M").ColumnWidth = 1.25
      xlSheet.Range("N:P").ColumnWidth = 5

     '填写栏标“1-4”然后再做合并
      For i = 0 To Num_Table - 1
        For m = 0 To 3
        xlSheet.Cells(1 + 15 * i, 3 + 4 * m) = m + 1
        Next
      Next
    '合并单元格
    '之行合并
     For i = 0 To Num_Table - 1
      For j = 0 To 3
        With xlSheet.Range(xlSheet.Cells(1 + 15 * i, 2 + 4 * j), xlSheet.Cells(1 + 15 * i, 4 + 4 * j))
                  .Merge
                  .HorizontalAlignment = xlCenter
                  .VerticalAlignment = xlCenter
        End With
        With xlSheet.Range(xlSheet.Cells(13 + 15 * i, 1), xlSheet.Cells(13 + 15 * i, 2))
                  .Merge
                  .HorizontalAlignment = xlCenter
                  .VerticalAlignment = xlCenter
        End With
      Next
     Next
    '之列合并
    For i = 0 To Num_Table - 1
      For j = 0 To 2
       With xlSheet.Range(xlSheet.Cells(2 + 15 * i, 5 + 4 * j), xlSheet.Cells(12 + 15 * i, 5 + 4 * j))
                  .Merge
                  .HorizontalAlignment = xlCenter
                  .VerticalAlignment = xlCenter
        End With
        Next
      Next
      '填写内容
      '之固定文字“栏”“行”（“1-4”见合并前操作）“1-10”“导入的文字项目1、项目2、项目3”“-i-”
      For i = 0 To Num_Table - 1
      xlSheet.Cells(1 + 15 * i, 1) = "栏"
      xlSheet.Cells(2 + 15 * i, 1) = "行"
      xlSheet.Cells(13 + 15 * i, 1) = "-" & i + 1 & "-"
      For j = 1 To 10
      xlSheet.Cells(2 + 15 * i + j, 1) = j
      Next
      '导入的文字项目1、项目2、项目3
      For k = 0 To 3
      xlSheet.Cells(2 + 15 * i, 2 + 4 * k) = cell1
      xlSheet.Cells(2 + 15 * i, 3 + 4 * k) = cell2
      xlSheet.Cells(2 + 15 * i, 4 + 4 * k) = cell3
      Next
      Next
      'text2对应内容
      For i = 0 To Num_Table - 1
        For j = 0 To 3
          For k = 3 To 12
          xlSheet.Cells(k + 15 * i, 3 + 4 * j) = List2.List(Num_List2)
          Num_List2 = Num_List2 + 1
          Next
        Next
      Next
      'text3对应内容
      For i = 0 To Num_Table - 1
        For j = 1 To 4
          For k = 3 To 12
          xlSheet.Cells(k + 15 * i, 4 * j) = List1.List(Num_List1)
          Num_List1 = Num_List1 + 1
          Next
        Next
      Next
     '页面设置
          With xlSheet.PageSetup
                  .TopMargin = 45
                  .LeftMargin = 20
                  .BottomMargin = 40
                  .RightMargin = 20
                  .Orientation = xlPortrait
                  .CenterHorizontally = True
                  .PaperSize = xlPaperB5
       '           .RightFooter = "第&P页,共&N页"
          End With
    
      'xlBook.Save "保存"
      'xlApp.ChangeFileOpenDirectory (App.Path)
      'xlApp.ActiveWorkbook.SaveAs = "表格.xls"
      'xlApp.ActiveDocument.Close savechanges:=xlDoNotSaveChanges
      'xlApp.Application.Quit
      Set xlApp = Nothing
failure:
End Sub