📄 change.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Begin VB.Form change
BorderStyle = 4 'Fixed ToolWindow
Caption = "数据表转换Excel"
ClientHeight = 4815
ClientLeft = 45
ClientTop = 285
ClientWidth = 7890
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4815
ScaleWidth = 7890
ShowInTaskbar = 0 'False
StartUpPosition = 1 '所有者中心
Begin MSAdodcLib.Adodc Adodc1
Height = 330
Left = 1320
Top = 5040
Visible = 0 'False
Width = 1200
_ExtentX = 2117
_ExtentY = 582
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 8
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 1
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = ""
OLEDBString = ""
OLEDBFile = ""
DataSourceName = ""
OtherAttributes = ""
UserName = ""
Password = ""
RecordSource = ""
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
Begin VB.Frame Frame1
Height = 4815
Index = 2
Left = 0
TabIndex = 0
Top = 0
Width = 7890
Begin VB.Frame Frame4
Caption = "当前进度"
Height = 750
Left = 3090
TabIndex = 4
Top = 2445
Width = 3810
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 285
Left = 45
TabIndex = 5
Top = 300
Width = 3645
_ExtentX = 6429
_ExtentY = 503
_Version = 393216
BorderStyle = 1
Appearance = 0
End
End
Begin VB.Frame Frame3
Height = 1980
Left = 3120
TabIndex = 3
Top = 180
Width = 3720
Begin VB.PictureBox TMaxAni1
Height = 1455
Left = 240
ScaleHeight = 1395
ScaleWidth = 3195
TabIndex = 7
Top = 240
Width = 3255
End
End
Begin VB.Frame Frame2
Caption = "资源列表"
Height = 4215
Left = 120
TabIndex = 1
Top = 270
Width = 2805
Begin VB.ListBox List2
Height = 3840
ItemData = "change.frx":0000
Left = 105
List = "change.frx":0002
TabIndex = 2
Top = 225
Width = 2595
End
End
Begin MSComctlLib.Toolbar Toolbar4
Height = 600
Left = 3795
TabIndex = 6
Top = 3480
Width = 2295
_ExtentX = 4048
_ExtentY = 1058
ButtonWidth = 1984
ButtonHeight = 1005
Style = 1
TextAlignment = 1
ImageList = "ImageList4"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 2
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "导出"
ImageIndex = 1
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "取消"
ImageIndex = 2
EndProperty
EndProperty
BorderStyle = 1
End
End
Begin MSComctlLib.ImageList ImageList4
Left = 360
Top = 5040
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 32
ImageHeight = 32
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 2
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "change.frx":0004
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "change.frx":08DE
Key = ""
EndProperty
EndProperty
End
End
Attribute VB_Name = "change"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim dbasize2 As Long
Dim dbasize As Long
Dim PathName As String
Private Sub Form_Load()
'TMaxAni1.FileName = App.Path & "\icon\find.gif"
'TMaxAni1.ShowGif
Dim cnn1 As ADODB.Connection
Dim rstschema As ADODB.Recordset
Dim strcnn As String
Set cnn1 = New ADODB.Connection
strcnn = "provider=Microsoft.jet.oledb.4.0;" & "data source=" & App.Path & "\db.mdb"
cnn1.Open strcnn
Set rstschema = cnn1.OpenSchema(adSchemaTables)
Do Until rstschema.EOF
temp = rstschema!Table_Name
If Left(temp, 1) <> "M" Then
List2.AddItem temp
End If
rstschema.MoveNext
Loop
cnn1.Close
List2.ListIndex = 0
On Error GoTo err
PathName = App.Path & "\db.MDB"
dbasize = FileLen(PathName)
err:
Exit Sub
End Sub
Private Sub Toolbar4_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
Dim provider As String
Dim datasource As String
provider = "provider=Microsoft.jet.oledb.4.0"
datasource = "data source=" & App.Path & "\DB.mdb"
With Adodc1
.Mode = adModeReadWrite
.ConnectionString = provider & ";" & datasource
.CommandType = adCmdTable
.RecordSource = List2.Text
.Refresh
End With
ProgressBar1.Max = Adodc1.Recordset.RecordCount
ProgressBar1.Min = 0
'开始转换
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.add
Set xlSheet = xlBook.Worksheets(1)
With Adodc1.Recordset
.MoveLast
If .RecordCount < 1 Then
MsgBox ("Error!")
Exit Sub
End If
Irowcount = .RecordCount
Icolcount = .Fields.Count
ReDim Fieldlen(Icolcount)
.MoveFirst
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1).Name
Case 2
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(.Fields(Icol - 1).Name)
Else
Fieldlen(Icol) = LenB(.Fields(Icol - 1))
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
Case Else
Fieldlen1 = LenB(.Fields(Icol - 1))
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
Fieldlen(Icol) = Fieldlen1
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next
If Irow <> 1 Then
If Not .EOF Then .MoveNext
ProgressBar1.Value = ProgressBar1.Value + 1
End If
Next
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
.Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
.Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
End With
xlApp.Visible = True
' xlBook.Save
'xlBook.Close
Set xlApp = Nothing
Adodc1.Recordset.ActiveConnection = Nothing
End With
Toolbar4.Buttons(1).Enabled = False
Case 2
Unload Me
End Select
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -