form1.frm

华宁软件N63.5检

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Excel转换数据"
   ClientHeight    =   6900
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7425
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6900
   ScaleWidth      =   7425
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1 
      Height          =   1815
      Left            =   1920
      TabIndex        =   10
      Top             =   2400
      Visible         =   0   'False
      Width           =   3615
      Begin VB.Label Label2 
         Caption         =   "正在处理..."
         BeginProperty Font 
            Name            =   "楷体_GB2312"
            Size            =   26.25
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   -1  'True
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H000000FF&
         Height          =   855
         Left            =   120
         TabIndex        =   11
         Top             =   720
         Width           =   3375
      End
   End
   Begin MSComDlg.CommonDialog cd1 
      Left            =   4320
      Top             =   120
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command4 
      Caption         =   "选excel文件"
      Height          =   375
      Left            =   2880
      TabIndex        =   9
      Top             =   6480
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   375
      Left            =   7320
      TabIndex        =   8
      Top             =   6840
      Visible         =   0   'False
      Width           =   735
   End
   Begin VB.TextBox Text2 
      Height          =   270
      Left            =   5160
      TabIndex        =   6
      Top             =   6480
      Width           =   1095
   End
   Begin VB.CommandButton Command3 
      Caption         =   "生成文件"
      Height          =   375
      Left            =   1560
      TabIndex        =   5
      Top             =   6480
      Width           =   1095
   End
   Begin VB.TextBox Text1 
      Height          =   4695
      Left            =   7320
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   4
      Top             =   -480
      Visible         =   0   'False
      Width           =   5655
   End
   Begin VB.CommandButton Command1 
      Caption         =   "选择文件夹"
      Height          =   375
      Left            =   -960
      TabIndex        =   3
      Top             =   6840
      Visible         =   0   'False
      Width           =   1215
   End
   Begin VB.Timer Timer1 
      Interval        =   1000
      Left            =   3120
      Top             =   240
   End
   Begin VB.FileListBox File1 
      Height          =   5130
      Left            =   7200
      MultiSelect     =   2  'Extended
      TabIndex        =   2
      Top             =   6720
      Visible         =   0   'False
      Width           =   2535
   End
   Begin VB.DriveListBox Drive1 
      Height          =   300
      Left            =   720
      TabIndex        =   1
      Top             =   360
      Width           =   1575
   End
   Begin VB.DirListBox Dir1 
      Height          =   5340
      Left            =   720
      TabIndex        =   0
      Top             =   840
      Width           =   4095
   End
   Begin VB.Label Label1 
      Caption         =   "工程代号"
      Height          =   255
      Left            =   4200
      TabIndex        =   7
      Top             =   6480
      Width           =   855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  Dim savepath1 As String
  Const LB_SETHORIZONTALEXTENT = &H194
  Private shlShell As Shell32.Shell
Private shlFolder As Shell32.Folder
Private Const BIF_RETURNONLYFSDIRS = &H1
Dim p1 As String
Dim fileextend As String '文件扩展名
Dim filepath As String '文件路径
Dim filecount1 As Integer '文件个数
Dim shuju(1000, 20000) As String
Dim str1, str2 As String

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet




Private Sub Command1_Click()
 On Error GoTo aa
   If shlShell Is Nothing Then
         Set shlShell = New Shell32.Shell
    End If
  
    Set shlFolder = shlShell.BrowseForFolder(Me.hwnd, "请选择文件夹", _
                                            BIF_RETURNONLYFSDIRS)
    If Not shlFolder Is Nothing Then
           Dim fs As New FileSystemObject

   '′利用filesystemobject对象的fileexists

   '方法判断文件是否存在
   If fs.FolderExists(shlFolder.Items.Item.Path) Then
   Dir1.Path = shlFolder.Items.Item.Path
  
   Else
   MsgBox "路径选择错误！"
   End If
    End If
GoTo cc:
aa: MsgBox "此文件夹不可选！请重新选择。"
Call Command1_Click
cc:
End Sub

Private Sub Command2_Click()
Text1.Visible = False
End Sub

Private Sub Command3_Click()
Frame1.Visible = True
     DoEvents
Command3.Enabled = False
Command4.Caption = "正在处理"
Command4.Enabled = False

If Text2.Text = "" Then
MsgBox "请填写工程号"
Else
If Text1.Text = "" Then
MsgBox "请选择要转换的Excel文件"
Else
str1 = Text1.Text & Chr(13) & Chr(10)

For i = 1 To 1000
   For j = 1 To 1000
    shuju(i, j) = "-1"
   Next
Next
i = 1
j = 1
Do While Len(str1) > 3

str2 = Mid(str1, 1, InStr(1, str1, vbCrLf, vbTextCompare) - 1)
If Len(str2) > 2 Then
  Do While Len(str2) > 1
  shuju(i, j) = Mid(str2, 1, InStr(1, str2, ",", vbTextCompare) - 1)
'MsgBox i & " " & j & " " & shuju(i, j)
  j = j + 1
  str2 = Mid(str2, InStr(1, str2, ",", vbTextCompare) + 1)
'MsgBox str2


   Loop
End If


str1 = Mid(str1, InStr(1, str1, vbCrLf, vbTextCompare) + 2)
i = i + 1
j = 1
'MsgBox str1

Loop



For j = 3 To 1000
If shuju(1, j) <> "-1" Then
  Open Dir1.Path & "\n63" & shuju(1, j) & "." & Text2.Text For Output As #1
   For i = 2 To 1000
      If shuju(i, j) = "-1" Then
      Exit For
      End If
      Print #1, shuju(i, 1) & "," & shuju(i, j)
   Next
  Close #1

  
End If
Next
MsgBox "处理完成"

End If
End If
Frame1.Visible = False
Command4.Caption = "选Excel文件"
Command4.Enabled = True
Command3.Enabled = True
End Sub

Private Sub Command4_Click()
On Error GoTo cc
 DoEvents
Command3.Enabled = False
Command4.Caption = "正在处理"
Command4.Enabled = False
Frame1.Visible = True
Set xlApp = CreateObject("Excel.Application")
cd1.Filter = "(excel文档)|*.xls|所有文件|*.*"
Text1.Text = ""
aa = ""
cd1.ShowOpen
Set xlBook = xlApp.Workbooks.Open(cd1.FileName)
cd1.FileName = ""
xlApp.Visible = False
Set xlSheet = xlBook.Worksheets("Sheet1")
'xlSheet.Cells(Row, Col) = 值
'xlSheet.Cells(1, 1) = ""
'xlSheet.PrintOut
k = 1
f = 1
For i = 3 To 1000 '列
 If xlSheet.Cells(1, i) <> "" Then
  k = k + 1
 ' MsgBox xlSheet.Cells(1, i)
 Else
  Exit For
 End If
Next
k = k + 1
For i = 2 To 1000 '行
 If xlSheet.Cells(i, 2) <> "" Then
  m = m + 1
 Else
  Exit For
 End If
Next
m = m + 1

'MsgBox k
For i = 1 To m
  For j = 1 To k
  
  aa = aa & xlSheet.Cells(i, j) & ","
 ' MsgBox i & " ," & j
  Next
 aa = aa + vbCrLf
Next
Text1.Text = aa
xlBook.Close (True)
xlApp.Quit
Set xlApp = Nothing

MsgBox "处理完成，可以生成文件"
GoTo dd
cc: MsgBox "选择错误!"
dd:
Frame1.Visible = False
Command4.Caption = "选Excel文件"
Command4.Enabled = True
Command3.Enabled = True
End Sub

Private Sub Dir1_Change()
On Error Resume Next
File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
On Error Resume Next
Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
Text1.Width = Form1.Width - 100
Text1.Height = Form1.Height - 800
Text1.Top = 0
Text1.Left = 0
Command1.Top = Text1.Top + Text1.Height
Command2.Top = Text1.Top + Text1.Height
Command3.Top = Text1.Top + Text1.Height
Command4.Top = Text1.Top + Text1.Height

Label1.Top = Text1.Top + Text1.Height
Text2.Top = Text1.Top + Text1.Height
'Text1.Visible = False
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Dir1.Path = Drive1.Drive
File1.Path = Dir1.Path
Timer1.Enabled = False
End Sub