Почему код выдает ошибку "Путь не найден"?

Question

У меня есть следующий код , но только проблема в том , что в строке : Set oFolder = fs.GetFolder(cDir) он пишет , что путь не найден. как исправить?

Private Sub CommandButton1_Click()
MyArrFromForm
InitializeDoc
Rose
End Sub

Private Sub CommandButton2_Click()
LoadTextPart2
End Sub

Private Sub CommandButton3_Click()
UserForm2.Show
End Sub

Private Sub CommandButton4_Click()
UserForm1.Hide
End Sub

Private Sub CommandButton5_Click()
Module1.login

End Sub

Private Sub TextBox13_Change()

End Sub

Private Sub TextBox17_Change()

End Sub

Private Sub TextBox29_Change()

End Sub

Private Sub TextBox30_Change()

End Sub

Private Sub TextBox9_Change()

End Sub

Private Sub UserForm_Click()

End Sub
Public Sub UserForm_Activate()
    cDir = CurDir("C") + "\" + "vbaLog"
    Set fs = CreateObject("Scripting.FileSystemObject")
        Set oFolder = fs.GetFolder(cDir)
        For Each oFile In oFolder.Files
            ListBox1.AddItem (oFile.name)
            ListBox2.AddItem (ReadFile(oFile.Path))
        Next oFile
   
End Sub

Public Sub AddFile(name As String, p As String, m As String)
    Open cDir + "\" + name For Output As #1
    Print #1, p
    Print #1, m
    Close #1
End Sub

Public Function ReadFile(p As String) As String
    Dim checkp, lvl As String
    Open p For Input As #1
    Do While Not EOF(1)
        If (checkp = "") Then
            Line Input #1, checkp
            Line Input #1, lvl
        End If
    Loop
    Close #1
    ReadFile = checkp
End Function

Public Sub CommandButton1_Click()
Label1.Caption = "Симаков Максим"
Label2.Caption = Date
Label3.Caption = "Первая подгруппа"
End Sub

Public Sub CommandButton2_Click()
ReplaceTextPart2
End Sub

Public Sub CommandButton3_Click()
UserForm2.Hide
End Sub

Public Sub TextBox3_Change()

End Sub

Public Sub UserForm_Click()

End Sub

Dim FocusOn As Boolean
Dim cDir As String

Public Sub ComboBox1_Change()
    TextBox2.Visible = False
    TextBox3.Visible = False
    ComboBox2.Visible = False
    If (ComboBox1.Value = "Регистрация" Or ComboBox1.Value = "Редактирование") Then
        TextBox2.Visible = True
        TextBox3.Visible = True
        If (ComboBox1.Value = "Регистрация") Then
            ComboBox2.Visible = True
        End If
    End If
    If (ComboBox1.Value = "Удалить") Then
        TextBox2.Visible = True
    End If
End Sub


Public Sub CommandButton4_Click()
    Dim state, idx As Integer
    Dim lvl, login, checkp, tmp As String
    state = 0
    idx = 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (ComboBox1.Value = "Регистрация") Then
        If (TextBox2.Value <> "") And (TextBox3.Value <> "") And (ComboBox2.Value <> "") Then
            state = 1
            Set oFolder = fs.GetFolder(cDir)
            For Each oFile In oFolder.Files
                If (oFile.name = TextBox2.Value) Then
                    MsgBox ("Указанный вами логин уже существует!")
                    state = -1
                    Exit For
                End If
            Next oFile
            If (state = 1) Then
                login = TextBox2.Value
                If (ComboBox2.Value = "Ограниченный доступ") Then
                    lvl = "1"
                End If
                If (ComboBox2.Value = "Доступно всё") Then
                    lvl = "2"
                End If
                If (ComboBox2.Value = "Продвинутый пользователь") Then
                    lvl = "3"
                End If
                ListBox1.AddItem (TextBox2.Value)
                Open cDir + "\" + login For Output As #1
                Print #1, TextBox3.Value
                Print #1, lvl
                Close #1
            End If
        End If
    End If
    If (ComboBox1.Value = "Редактирование") Then
        If (ListBox1.text <> "") And (TextBox2.Value <> "") And (TextBox3.Value <> "") Then
            login = ListBox1.text
            checkp = ReadFile(cDir + "\" + login)
            If (checkp = TextBox2.Value) Then
                Open cDir + "\" + login For Input As #1
                Line Input #1, tmp
                Line Input #1, lvl
                Close #1
                Open cDir + "\" + login For Output As #1
                Print #1, TextBox3.Value
                Print #1, lvl
                Close #1
                MsgBox ("Пароль был успешно изменен!")
            Else
                MsgBox ("Неправильный пароль")
            End If
        End If
    End If
    If (ComboBox1.Value = "Удалить") Then
        If (ListBox1.text <> "") And (TextBox2.Value <> "") Then
             login = ListBox1.text
             checkp = ReadFile(cDir + "\" + login)
             If (checkp = TextBox2.Value) Then
                fs.DeleteFile (cDir + "\" + login)
                For Each itm In ListBox1.List
                    If login = itm Then
                        Exit For
                    Else
                        idx = idx + 1
                    End If
                Next itm
                ListBox1.RemoveItem (idx)
                MsgBox ("Аккаунт был удален!")
             Else
                MsgBox ("Неправильный пароль")
             End If
        End If
    End If
    If (ComboBox1.Value = "Сортировка") Then
        ListBox1.Clear
        Dim n As Integer
        Dim strTmp As String
        Set fld = fs.GetFolder(cDir)
        n = fld.Files.Count
        ReDim arrNames(1 To n)
        ReDim arrDates(1 To n)
    
        ' Fill arrays
        For Each fil In fld.Files
            I = I + 1
            arrNames(I) = fil.name
            arrDates(I) = fil.DateCreated
        Next fil
    
        ' Bubble sort descending on date
        For I = 1 To n - 1
            For J = I + 1 To n
                If arrDates(I) < arrDates(J) Then
                    dtmTmp = arrDates(I)
                    arrDates(I) = arrDates(J)
                    arrDates(J) = dtmTmp
                    strTmp = arrNames(I)
                    arrNames(I) = arrNames(J)
                    arrNames(J) = strTmp
                End If
            Next J
        Next I
        For I = n To 1 Step -1
            ListBox1.AddItem (arrNames(I))
        Next I
    End If
End Sub

Public Sub TextBox1_Enter()
    FocusOn = True
End Sub

Public Sub UserForm_Activate()
    ComboBox1.AddItem ("Регистрация")
    ComboBox1.AddItem ("Редактирование")
    ComboBox1.AddItem ("Удалить")
    ComboBox1.AddItem ("Сортировка")
    ComboBox2.AddItem ("Ограниченный доступ")
    ComboBox2.AddItem ("Доступно всё")
    ComboBox2.AddItem ("Продвинутый пользователь")
    cDir = CurDir("C") + "\" + "vbaLog"
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FolderExists(cDir)) Then
        Set oFolder = fs.GetFolder(cDir)
        For Each oFile In oFolder.Files
            ListBox1.AddItem (oFile.name)
        Next oFile
    End If
End Sub

Public Function ReadFile(p As String) As String
    Dim checkp, lvl As String
    Open p For Input As #1
    Do While Not EOF(1)
        If (checkp = "") Then
            Line Input #1, checkp
        Else
            Line Input #1, lvl
        End If
    Loop
    Close #1
    ReadFile = checkp
End Function

Public doc
Dim R
Dim aTitleList(1 To 20) As String 'массив заголовков
Dim aFieldsList(1 To 20, 1 To 20) As String   'массивданных
Dim aPart(1 To 3)
Public oFolder
Public cDir As String

Dim PermissionLvl As Integer

Public Sub login()
    Dim login, passw, checkp, cDir, lvl As String
    login = UserForm1.ListBox1.text
    passw = UserForm1.ListBox2.text
    PermissionLvl = 1
    checkp = ""
    cDir = CurDir("C") + "\vbaLog"
    Set fs = CreateObject("Scripting.FileSystemObject")
    If (fs.FileExists(cDir + "\" + login)) Then
        Open cDir + "\" + login For Input As #1
        Do While Not EOF(1)
            If (checkp = "") Then
                Line Input #1, checkp
            Else
                Line Input #1, lvl
            End If
        Loop
        Close #1
        If (passw = checkp) Then
            MsgBox ("Успешая авторизация!")
            PermissionLvl = lvl
        Else
            MsgBox ("Неправильный пароль!")
        End If
    Else
        MsgBox ("Неправильный логин!")
    End If
    UpdateForm
End Sub

Public Sub UpdateForm()

If (PermissionLvl = 1) Then
    UserForm1.CommandButton5.Visible = False
    UserForm1.CommandButton6.Visible = False
    UserForm1.CommandButton7.Visible = False
    UserForm1.CommandButton3.Visible = False
Else
        UserForm1.CommandButton5.Visible = False
        UserForm1.CommandButton6.Visible = False
        UserForm1.CommandButton7.Visible = False
    UserForm1.CommandButton3.Visible = True
    If (PermissionLvl = 3) Then
        UserForm1.CommandButton5.Visible = True
        UserForm1.CommandButton6.Visible = True
        UserForm1.CommandButton7.Visible = True
    End If
End If
End Sub

Public Function CreateNewWordDocument(temppath)
  Dim wd
'Переменная для хранения ссылки на документ
'Создание объекта Word.Application
  Set App = CreateObject("Word.Application")
  App.Visible = True
  Set wd = App.Documents.Add(temppath)
  Set CreateNewWordDocument = wd

End Function
Sub CreateDocument()
 Dim temppath As String
MsgBox ("Приветствую смотрящих")
'Создание объекта – документа
 Set doc = CreateNewWordDocument(temppath)
' Установка отступов
With doc
.PageSetup.LeftMargin = CentimetersToPoints(2)
.PageSetup.RightMargin = CentimetersToPoints(1.5)
End With
doc.Styles("Обычный").Font.Size = "12"
doc.Styles("Без интервала").Font.Size = "12"
doc.Styles("Без интервала").Font.Color = Black
doc.Styles("Без интервала").Font.Italic = True
doc.Styles("Без интервала").Font.Bold = True
doc.Styles("Без интервала").ParagraphFormat.Alignment = wdAlignParagraphCenter
'Активация документа
doc.Activate
'Функция CreateNewWordDocument (TempPath):
End Sub

'Пример задания диапазонов Range.Фрагменты программного кода.
'Функция для создания параграфов в документе Word
Public Function AddNewParagraphRange(aRange)
Dim NewParagraph
Dim NewRange
Dim I As Integer
I = aRange.Paragraphs.Count
aRange.InsertParagraphAfter
Set NewRange = aRange.Paragraphs(I).Range
NewRange.StartOf wdWord, wdMove
Set AddNewParagraphRange = NewRange
End Function





Public Function WriteParagraphLn(aRange, text, StyleName) As Range
   Dim stpos As Long 'объявление переменной
   stpos = aRange.End 'запоминаем ссылку на конец диапазона
If Len(aRange) <= 2 Then
   aRange.InsertAfter text
Else
  aRange.InsertParagraphAfter 'вводим пустой абзац после текста
  stpos = aRange.End
  aRange.InsertAfter text  'вводим текст
End If
'присваиваем диапазону нужный шрифт
If StyleName <> "" Then _
aRange.Document.Range(stpos, aRange.End).Style = StyleName


'присваиваем функции изменённый диапазон с текстом нужного шрифта
Set WriteParagraphLn = aRange.Document.Range(stpos, aRange.End)

End Function


Public Function AddTableIntoRange(IntoRange, NumCols, NumRows, Autofit)
   Dim rngRange As Range
   Dim RR As Range
If Len(IntoRange) > 2 Then
   IntoRange.InsertAfter " "
   Set rngRange = _
   IntoRange.Document.Range(IntoRange.End - 1, _
   IntoRange.End - 1)
Else
Set rngRange = _
IntoRange.Document.Range(IntoRange.Start, _
IntoRange.Start)
End If
Dim t
Set t = rngRange.Tables.Add(rngRange, NumRows, NumCols)
If Autofit Then t.AutoFitBehavior wdAutoFitContent
t.Range.Style = "Обычный"
IntoRange.Paragraphs.Last.Style = "Обычный"

Set AddTableIntoRange = t
End Function

'процедуру сбора данных из полей ввода напишите сами
Public Sub InsertTableConstructor(rng, ColNum, StrNum, TitleList, FieldsList)
Dim t As Table
Dim I, J As Integer
Set t = AddTableIntoRange(rng, ColNum, 1, False)
'вставляем заголовок
For I = 1 To ColNum
WriteParagraphLn t.Cell(1, I).Range, TitleList(I), "Обычный"
Next I
J = 1 'начнём с первой строки
Do
  t.Rows.Add 'новая строка
  For I = 1 To ColNum
'заполнение данными строки
   WriteParagraphLn t.Cell(J + 1, I).Range, FieldsList(J, I), "Обычный"
 Next I
J = J + 1
Loop Until J = StrNum
'при вызове процедуры надо учесть сдвиг на 1 на заголовок таблицы
' выравнивание
With t
    .Borders.InsideLineStyle = wdLineStyleSingle
    .Borders.OutsideLineStyle = wdLineStyleSingle
    .Borders.OutsideLineWidth = wdLineWidth225pt
    .Borders.InsideLineWidth = wdLineWidth225pt
    .Rows(1).Range.Bold = True
    .Borders.InsideColor = 3
    .Rows(1).Shading.BackgroundPatternColor = wdColorGreen
    .Rows(1).Range.Font.Color = wdColorRed
End With


t.AutoFitBehavior wdAutoFitWindow
End Sub
Public Sub Rose()
Call LoadTableFromTB
Call LoadTextPart3
End Sub
'Процедура для создания диапазонов в документе Word
Public Sub InitializeDoc()
Call CreateDocument
 
'Установка объекта типа Range в рамках объекта Document
 Set R = doc.Range

 'Установка
 Set aPart(1) = AddNewParagraphRange(R)
 Set aPart(2) = AddNewParagraphRange(R)
 Set aPart(3) = AddNewParagraphRange(R)
 Set aPart(1) = WriteParagraphLn(aPart(1), "Таблица ввода данных", "Без интервала")
 Set aPart(2) = WriteParagraphLn(aPart(2), "В форме была добавлена кнопка выход , для удобства при проверке", "Без интервала")
 
 Dim ThisDay As Integer
 This_hour = Hour(Time)
 This_minutes = Minute(Time)
 hour_and_minutes = CStr(This_hour) + ":" + CStr(This_minutes)
 Data = Weekday(Date)
 If Data = 1 Then Den_nedeli = "Воскресенье"
 If Data = 2 Then Den_nedeli = "Понедельник"
 If Data = 3 Then Den_nedeli = "Вторник"
 If Data = 4 Then Den_nedeli = "Среда"
 If Data = 5 Then Den_nedeli = "Четверг"
 If Data = 6 Then Den_nedeli = "Пятница"
 If Data = 7 Then Den_nedeli = "Суббота"
 
 
End Sub
Public Sub LoadTableFromTB()
  aTitleList(1) = MyArr(1)
  aTitleList(2) = MyArr(2)
  aTitleList(3) = MyArr(3)
  aTitleList(4) = MyArr(4)
  aTitleList(5) = MyArr(5)
  aTitleList(6) = MyArr(6)
  For I = 1 To 5
    aFieldsList(I, 1) = MyArr(6 * I + 1)
    aFieldsList(I, 2) = MyArr(6 * I + 2)
    aFieldsList(I, 3) = MyArr(6 * I + 3)
    aFieldsList(I, 4) = MyArr(6 * I + 4)
    aFieldsList(I, 5) = MyArr(6 * I + 5)
    aFieldsList(I, 6) = MyArr(6 * I + 6)
    Next I
    Call InsertTableConstructor(aPart(1), 6, 5, aTitleList, aFieldsList)
End Sub
Public Sub LoadTextPart3()

Set aPart(3) = WriteParagraphLn(aPart(3), "                                           ", "Обычный")
Set aPart(3) = WriteParagraphLn(aPart(3), UserForm1.TextBox37.text + " " + UserForm1.TextBox38.text, "Обычный")


End Sub


Public Sub LoadTextPart2()
Set aPart(2) = WriteParagraphLn(aPart(2), "               ", "Без интервала")
Set aPart(2) = WriteParagraphLn(aPart(2), "------------------------Строка разделитель-------------------", "Без интервала")

End Sub
Public Sub ReplaceTextPart2()

aPart(2).Delete


MyDate = Format(Now, "d")
  If (MyDate Mod 2) = 0 Then
      Set aPart(2) = WriteParagraphLn(aPart(2), "Раздел на реконструкции", "Без интервала")
  Else
   Set aPart(2) = WriteParagraphLn(aPart(2), "Не обслуживается", "Без интервала")
  End If

End Sub

БЛОГ НА HUSL

Почему код выдает ошибку "Путь не найден"?

Ответы (0 шт):