Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
Алиби
0 / 0 / 0
Регистрация: 05.04.2017
Сообщений: 1
#1

Конвертировать тест c 5 вариантами и 1 правильным ответом в тест с 8 вариантами и 3 правильными ответами

09.12.2014, 20:33. Просмотров 296. Ответов 0
Метки нет (Все метки)

Подскажите как мне переделать макрос. Он для конвертирования документа ворд с 5 вопросами с одним правильным ответом. Хотел переделать его для 8 вопросом с 3 правильными ответами.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
Option Explicit
Public Start As Boolean
Public Files() As String
Public FilesCount As Long
 
Sub Start_()
  FilesCount = 0
  frmConvert.Show
  If Start = True And FilesCount > 0 Then
    StartConvert
  End If
End Sub
 
Sub StartConvert()
  Dim i As Long
  Dim doc As Document, fname As String
  For i = 1 To FilesCount
    fname = Left(Files(i), Len(Files(i)) - 4) + ".rtf"
    If Dir(Files(i)) <> "" Then
      Set doc = Application.Documents.Open(Files(i))
      ConvertTest doc, fname
      doc.Close
      Set doc = Nothing
    End If
  Next i
End Sub
 
Sub ConvertTest(curdoc As Document, SaveToFile As String)
    Dim d1 As Document, CurTableCount As Long, curCellWordCount As Long
    Dim c1, table_ As Long, curTableRowCount As Long, i As Long, k As Long
    Dim FirstRow As Long, noCheck As Boolean ' если тру то проверка не нужна
        
    'Dim curdoc As Document,
    table_ = 1
    'Set curdoc = ActiveDocument
    Set d1 = Documents.Add
    CurTableCount = curdoc.Tables.count
  For table_ = 1 To CurTableCount
    curTableRowCount = curdoc.Tables(table_).Rows.count
    If table_ > 1 Then FirstRow = 1 Else FirstRow = 2
    For c1 = FirstRow To curTableRowCount
        'If Len(Trim(curdoc.Tables(table_).Cell(c1, 3).Range.Text)) < 4 Then GoTo nxt
        d1.Application.Selection.Start = d1.Range.End
        d1.Application.Selection = "Question: "
        'next
        'if trim(
        noCheck = False
        curCellWordCount = curdoc.Tables(table_).Cell(c1, 3).Range.Words.count - 1
        For i = 1 To curCellWordCount
            If noCheck Then
               curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Copy
               d1.Application.Selection.Start = d1.Range.End
               d1.Application.Selection.Paste
             Else
              If Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) <> "" And _
                 Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) <> vbCr Then
                'Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) <> vbCrLf or
                  noCheck = True
                  If Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) = "" Or _
                     Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) = vbCr Or _
                     Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) = vbLf Or _
                     Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) = vbCrLf Then
                    'Trim$(curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).Text) <> vbCrLf or
                    Else
                      curdoc.Tables(table_).Cell(c1, 3).Range.Words(i).CopyAsPicture
                      d1.Application.Selection.Start = d1.Range.End
                      d1.Application.Selection.Paste
                  End If
              End If
            End If
        Next
        For k = 1 To 5
          d1.Application.Selection.Start = d1.Range.End
          d1.Application.Selection = vbCrLf & "Answer: "
          d1.Application.Selection.Start = d1.Range.End
          noCheck = False
          'ответk
            curCellWordCount = curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words.count - 1
            For i = 1 To curCellWordCount
              'If curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text <> " " Then
                If noCheck Then
                curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Copy
                d1.Application.Selection.Start = d1.Range.End
                d1.Application.Selection.Paste
                Else
                  If Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) <> "" And _
                     Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) <> vbCr Then
                    'Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) <> vbCrLf or
                      noCheck = True
                      If Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) = "" Or _
                         Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) = vbCr Or _
                         Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) = vbLf Or _
                         Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) = vbCrLf Then
                        'Trim$(curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Text) <> vbCrLf or
                        Else
                          curdoc.Tables(table_).Cell(c1, 4 + k).Range.Words(i).Copy
                          d1.Application.Selection.Start = d1.Range.End
                          d1.Application.Selection.Paste
                      End If
                  End If
                End If
              'Else
              '  d1.Application.Selection.Start = d1.Range.End
              '  d1.Application.Selection.Text = ""
              'End If
            Next
            'd1.Application.Selection.Text
        Next
        d1.Application.Selection.Start = d1.Range.End
        d1.Application.Selection = vbCrLf & "Correct: 1" & vbCrLf & vbCrLf
nxt:
    Next
  Next
    'd1.Range.FormattedText.Words.Item = c1
    d1.SaveAs SaveToFile, wdFormatRTF
    d1.Close
    'Set curdoc = Nothing
    Set d1 = Nothing
End Sub

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь.

0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
09.12.2014, 20:33
Ответы с готовыми решениями:

Массив с вариантами уравнений(формул)
Наглядных файлов примера нет, хочу разобраться в теории, так как поисковики не...

Программирование алгоритмов ветвлений со многими вариантами
Помогите пожалуйста составить программу, определяющую по введенной дисциплине,...

VBA Excel: окно вывода с вариантами ответа
Нужно создать в экселе макросах окно вывода с вариантами ответа на вопрос...

Тест
помогите пожалуйста, нужно составить 15+ вопростов по теме &quot;Операторы цикла&quot; и...

Тест
Помогите решить тест

0
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
09.12.2014, 20:33

Тест VBA
1. Дополните оператор объявления типа Dim theVar As ________чтобы переменная...

Тест VBA
Помогите плз доделать тест 1. Каких типов данных не существует в языке VBA: ...

Тест VBA
Здравствуйте, у меня проблемка возникла при создании теста в VBA, если не...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
1
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru