Rob
/
FrymasterVB
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
FrymasterVB/Cmdproc-6.frm

407 lines
12 KiB
Plaintext
Raw Permalink Blame History

VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDatGrd.ocx"
Begin VB.Form frmFolderCopy
Caption = "Folder Copy"
ClientHeight = 7335
ClientLeft = 60
ClientTop = 450
ClientWidth = 8400
LinkTopic = "Form1"
ScaleHeight = 7335
ScaleWidth = 8400
StartUpPosition = 3 'Windows Default
Begin MSDataGridLib.DataGrid DataGrid1
Bindings = "Cmdproc-6.frx":0000
Height = 915
Left = 300
TabIndex = 7
Top = 5370
Width = 8025
_ExtentX = 14155
_ExtentY = 1614
_Version = 393216
HeadLines = 1
RowHeight = 15
FormatLocked = -1 'True
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 4
BeginProperty Column00
DataField = "HFLD#"
Caption = "HFLD#"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = "HPRD#"
Caption = "HPRD#"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column02
DataField = "HHEX"
Caption = "HHEX"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column03
DataField = "HENTD"
Caption = "HENTD"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
ColumnWidth = 1275.024
EndProperty
BeginProperty Column01
ColumnWidth = 1260.284
EndProperty
BeginProperty Column02
ColumnWidth = 3209.953
EndProperty
BeginProperty Column03
ColumnWidth = 1590.236
EndProperty
EndProperty
End
Begin VB.ListBox List2
Height = 1425
Left = 300
TabIndex = 6
Top = 3870
Width = 8025
End
Begin VB.CommandButton cmdReadFileNames
Caption = "Read File Names"
Height = 345
Left = 4620
TabIndex = 5
Top = 60
Width = 3675
End
Begin VB.FileListBox File1
Height = 3015
Left = 4650
TabIndex = 4
Top = 450
Width = 3645
End
Begin VB.ListBox List1
Height = 1815
Left = 300
TabIndex = 3
Top = 1560
Width = 4095
End
Begin VB.CommandButton Command1
Caption = "Copy Folder"
Height = 435
Left = 690
TabIndex = 2
Top = 900
Width = 2955
End
Begin VB.TextBox pthDst
Height = 285
Left = 120
TabIndex = 1
Text = "Q:\A\8074932D"
Top = 420
Width = 4335
End
Begin VB.TextBox pthSrc
Height = 285
Left = 120
TabIndex = 0
Text = "\\fryfs001v\eng\users\FEDUCIA\8074932D"
Top = 90
Width = 4335
End
Begin MSAdodcLib.Adodc Adodc1
Height = 330
Left = 360
Top = 3540
Visible = 0 'False
Width = 8025
_ExtentX = 14155
_ExtentY = 582
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 2
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 3
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = "DSN=ODBCrms"
OLEDBString = ""
OLEDBFile = ""
DataSourceName = "ODBCrms"
OtherAttributes = ""
UserName = "EGNETLINK"
Password = "DRAWINGS"
RecordSource = "EGSHP1A0"
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
End
Attribute VB_Name = "frmFolderCopy"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright <20>1996-2006 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH As Long = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CreateDirectory Lib "kernel32" _
Alias "CreateDirectoryA" _
(ByVal lpPathName As String, _
lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function CopyFile Lib "kernel32" _
Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Dim fsoMain As FileSystemObject
Private Sub cmdReadFileNames_Click()
cmdReadFileNames.Enabled = False
On Error Resume Next
pthd$ = pthDst.Text
'SW00007C
List2.Clear
File1.Path = pthd$
fldr$ = UCase(Mid(pthd$, LastStr(pthd$, "\") + 1))
Pn$ = UCase(left(fldr$, 7))
File1.Refresh
If File1.Path = pthd$ Then
Recname$ = pthd$
recn# = 0
retry# = 0
If (Adodc1.Recordset.RecordCount <> 0) Then Adodc1.Recordset.MoveFirst
Do While (Not (Adodc1.Recordset.EOF)) And (Adodc1.Recordset.RecordCount <> 0)
rfld$ = UCase(Trim(Adodc1.Recordset![HFLD#]))
If rfld$ = fldr$ Then
Adodc1.Recordset.Delete
Pause (1)
retry# = retry# + 1
Else
recn# = recn# + 1
Adodc1.Recordset.MoveNext
End If
cmdReadFileNames.Caption = "retry=" + Str(retry#) + " - Recnum=" + Str(recn#)
Loop
cmdReadFileNames.Caption = "delete complete"
On Error GoTo 0
If File1.ListCount > 0 Then
For ixc = 0 To File1.ListCount - 1
nw$ = Format(Now, "yyyymmddhhnnss")
d# = Val(nw$)
flx$ = File1.List(ixc)
'
' add the record
List2.AddItem fldr$ + "|" + Pn$ + "|" + nw$ + "|" + flx$
Adodc1.Recordset.AddNew
Adodc1.Recordset![HFLD#] = fldr$
Adodc1.Recordset![HPRD#] = Pn$
Adodc1.Recordset!HHEX = RPad(flx$, 70)
Adodc1.Recordset!HENTD = d#
Adodc1.Recordset.Update
'
Next
End If
End If
cmdReadFileNames.Caption = "Read File Names"
cmdReadFileNames.Enabled = True
End Sub
Private Sub Command1_Click()
Dim sSourcePath As String
Dim sDestination As String
Dim sFiles As String
Dim numCopied As Long
'set the appropriate initializing values
sSourcePath = pathCheck(pthSrc)
sDestination = pathCheck(pthDst)
sFiles = "*.*"
'perform the copy and return the copied file count
numCopied = 0
Call Copydir(sSourcePath, sDestination, Rc%)
numCopied = Rc%
Call DeleteDir(sSourcePath)
End Sub
Public Sub Copydir(sSourcePath As String, sDestination As String, iRetCd As Integer)
Dim numCopied, numDeleted As Long
Dim fsosub As New FileSystemObject
'set the appropriate initializing values
pthDst = pathCheck(sDestination)
pthSrc = pathCheck(sSourcePath)
pthDst = left(pthDst, Len(pthDst) - 1)
pthSrc = left(pthSrc, Len(pthSrc) - 1)
ce = 0: On Error GoTo erretcopy
Call fsosub.CopyFolder(pthSrc, pthDst, True)
On Error GoTo 0
'
'place filenames in folder into the as400
'
If ce = 0 Then
Call cmdReadFileNames_Click
End If
iRetCd = ce
Pause (2)
Exit Sub
erretcopy:
ce = 1
Resume Next
End Sub
Public Sub KillDir(sSourcePath As String, iRetCd As Integer)
Dim sFiles As String
Dim numCopied, numDeleted As Long
'set the appropriate initializing values
sSourcePath = pathCheck(sSourcePath)
'MsgBox numCopied & " files copied to " & sDestination
Call DeleteDir(sSourcePath)
iRetCd = 0
End Sub
Private Sub DeleteDir(sSourcePath As String)
On Error Resume Next
Dim fsosub As New FileSystemObject
pthn$ = pathCheck(sSourcePath)
pthn$ = left(pthn$, Len(pthn$) - 1)
Call fsosub.DeleteFolder(pthn$, True)
End Sub
Reference in New Issue View Git Blame Copy Permalink