ReSQL.ru
     
powered by simpleCommunicator - 2.0.49     © 2025 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Макрос для перевода текста WORD в код для этого форума.
9 сообщений из 9, страница 1 из 1
Макрос для перевода текста WORD в код для этого форума.
    #32538047
Фотография Green2
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Green2Привилегированный пользователь
Участник
Версия 0, еще не тестировал, но уже выкладываю.

Надо протестировать на ошибки.

Предназначен для word 2000-2002

Перед началом работы надо импортировать модуль в VBA.

Работает так: отформатированный текст выделяется, затем запускается макрос и в результате создаётся новый документ, в котором содержиться отформатированный текст.

Код: plaintext
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.
Public Sub CopyToSqlRu2()
Dim doca As Document, docv As Document
Dim rna As Range, strRgn As String
Dim stHyp As Boolean, stBolid As Boolean
Dim stColor As WdColor
Dim stUnderline As Boolean
Dim stSize As Long
Dim rac As Range

strRgn = ""
stHyp = False
stBolid = False
stColor = wdColorAutomatic
stUnderline = False
stSize =  3 
For Each rac In Selection.Characters
    If rac.Hyperlinks.Count <>  0  And Not stHyp Then
        strRgn = strRgn & "" & rac.Hyperlinks( 1 ).Address & "]"
        stHyp = True
    End If
    If rac.Bold And Not stBolid Then
        strRgn = strRgn & ""
        stBolid = True
    End If
    If rac.Underline = wdUnderlineSingle And Not stUnderline Then
        strRgn = strRgn & ""
        stUnderline = True
    End If

    If PrivSizeFont(rac.Font.Size) <> stSize Then
        If stSize <>  [b]3  Then
            strRgn = strRgn & "[/size]"
        End If
    End If
        
    If rac.Font.Color <> stColor Then
    
        If stColor <> wdColorAutomatic Then
            strRgn = strRgn & "[/color]"
        End If
        
        If rac.Font.Color <> wdColorAutomatic Then
            strRgn = strRgn & "[color=#" & Hex(rac.Font.Color) & "]"
        End If
        
        stColor = rac.Font.Color
    End If
    
    If PrivSizeFont(rac.Font.Size) <> stSize Then
        If PrivSizeFont(rac.Font.Size) <>  3  Then
            strRgn = strRgn & "[size=" & PrivSizeFont(rac.Font.Size) & "]"
        End If
        stSize = PrivSizeFont(rac.Font.Size)
    End If
    
    If rac.Underline <> wdUnderlineSingle And stUnderline Then
        strRgn = strRgn & ""
        stUnderline = False
    End If
    
    If Not rac.Bold And stBolid Then
        strRgn = strRgn & "[/b]"
        stBolid = False
    End If
    If rac.Hyperlinks.Count =  0  And stHyp Then
        strRgn = strRgn & ""
        stHyp = False
    End If
    
    If rac.InlineShapes.Count <>  0  Then
        strRgn = strRgn & "[img=" & rac.InlineShapes.Item( 1 ).LinkFormat.SourceFullName & "]"
    Else
        strRgn = strRgn & rac.Text
    End If
    
Next rac
 'Çäåñü íàõîäèòüñÿ çàâåðøåíèå òåãîâ
 
If stColor <> wdColorAutomatic Then strRgn = strRgn & "[/color]"
If stSize <>  3  Then strRgn = strRgn & "[/size]"
If stUnderline Then strRgn = strRgn & "[/u]"
If stBolid Then strRgn = strRgn & "[/b]"
If stHyp Then strRgn = strRgn & ""

 'Set rna = Selection.Range
 
Set doca = ActiveDocument
Set docv = Application.Documents.Add
docv.Activate
Selection.Text = strRgn
doca.Activate

End Sub


Private Function PrivSizeFont(sz As Long)
    Select Case sz
    Case Is <=  7 
        PrivSizeFont =  1 
    Case  8 ,  9 
        PrivSizeFont =  2 
    Case  10 ,  11 
        PrivSizeFont =  3 
    Case  12 ,  13 
        PrivSizeFont =  4 
    Case Is >=  14 
        PrivSizeFont =  5 
    End Select
End Function

Извините, что спешу с опубликованием...
...
Рейтинг: 0 / 0
28.05.2004, 10:13
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32538666
Фотография funddd
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
funddd
Участник
дык это, [ src vba ] же есть
...
Рейтинг: 0 / 0
28.05.2004, 12:57
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32538779
Фотография Лох Позорный
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Лох Позорный
Участник
funddd, кажется ты не понял.
этот макрос из вордового документа делает текст с тегами этого форума.
надо будет потестить.
...
Рейтинг: 0 / 0
28.05.2004, 13:41
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32538913
Фотография funddd
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
funddd
Участник
туплю
...
Рейтинг: 0 / 0
28.05.2004, 14:27
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32539822
Фотография Green2
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Green2Привилегированный пользователь
Участник
Новая версия, проблемы с [size= ]
Еще бы надо italic и надстрочный текст сделать...
Код: plaintext
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.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
Attribute VB_Name = "NewMacros1"
Private strRgn As String
Private stHyp As Boolean, stBolid As Boolean
Private stColor As WdColor
Private stUnderline As Boolean
Private stSize As Long
Private rac As Range
Private stNewTag As Boolean

Private Sub InitParam()
    stHyp = False
    stBolid = False
    stColor = wdColorAutomatic
    stUnderline = False
    stSize =  3 
    stNewTag = False
End Sub

Public Sub CopyToSqlRu2()
Dim doca As Document, docv As Document

strRgn = ""
InitParam

For Each rac In Selection.Characters
   RecLink
    If rac.InlineShapes.Count <>  0  Then
        strRgn = strRgn & "[img=" & rac.InlineShapes.Item( 1 ).LinkFormat.SourceFullName & "]"
    Else
        strRgn = strRgn & rac.Text
    End If
    
Next rac
    EndStrings
 'Set rna = Selection.Range
 
Set doca = ActiveDocument
Set docv = Application.Documents.Add
docv.Activate
Selection.Text = strRgn
doca.Activate

End Sub


Private Function PrivSizeFont(sz As Long)
    Select Case sz
    Case Is <=  5 
        PrivSizeFont =  1 
    Case  5  To  7 
        PrivSizeFont =  2 
    Case  7  To  9 
        PrivSizeFont =  3 
    Case  9  To  11 
        PrivSizeFont =  4 
    Case Is >=  11 
        PrivSizeFont =  5 
    End Select
End Function

 'Здесь находиться завершение тегов
 
Private Sub EndStrings()
    If stHyp Then strRgn = strRgn & ""
    If stBolid Then strRgn = strRgn & "[/b]"
    If stUnderline Then strRgn = strRgn & "[/u]"
    If stSize <>  3  Then strRgn = strRgn & "[/size]"
    If stColor <> wdColorAutomatic Then strRgn = strRgn & "[/color]"
    InitParam
End Sub

 ' Работа с гиперлинками
 
Private Sub RecLink()
    If rac.Hyperlinks.Count =  0  And stHyp Then
        strRgn = strRgn & ""
        stHyp = False
    End If
    If rac.Hyperlinks.Count <>  0  And Not stHyp Then stNewTag = True
    RecBolid
    If rac.Hyperlinks.Count <>  0  And Not stHyp Then
        strRgn = strRgn & "" & rac.Hyperlinks( 1 ).Address & "]"
        stHyp = True
    End If
End Sub

 ' Жирный текст
 
Private Sub RecBolid()
    If Not rac.Bold And stBolid Then
        strRgn = strRgn & "[/b]"
        stBolid = False
    End If
    If rac.Bold And Not stBolid Then stNewTag = True
RecUnderline
    If rac.Bold And Not stBolid Then
        strRgn = strRgn & ""
        stBolid = True
    End If
End Sub

 ' Подчеркнутый текст
 
Private Sub RecUnderline()
    If rac.Underline <> wdUnderlineSingle And stUnderline Then
        strRgn = strRgn & "[/u]"
        stUnderline = False
    End If
    If rac.Underline = wdUnderlineSingle And Not stUnderline Then stNewTag = True
RecFont
    If rac.Underline = wdUnderlineSingle And Not stUnderline Then
        strRgn = strRgn & "[u]"
        stUnderline = True
    End If
End Sub

 ' Размер шрифта
 
Private Sub RecFont()
    If PrivSizeFont(rac.Font.Size) <> stSize Then
        If stSize <>  [b]3  Then
            strRgn = strRgn & "[/size]"
        End If
    End If
    If PrivSizeFont(rac.Font.Size) <> stSize Then stNewTag = True
RecColor
    If PrivSizeFont(rac.Font.Size) <> stSize Then
        If PrivSizeFont(rac.Font.Size) <>  3  Then
 '            EndStrings
 
            strRgn = strRgn & "[size=" & PrivSizeFont(rac.Font.Size) & "]"
        End If
        stSize = PrivSizeFont(rac.Font.Size)
    End If
End Sub

 ' Цвет шрифта
 
Private Sub RecColor()
    If rac.Font.Color <> stColor Then
        If stColor <> wdColorAutomatic Then
            strRgn = strRgn & "[/color]"
        End If
        If stNewTag Then EndStrings
        If rac.Font.Color <> wdColorAutomatic Then
            strRgn = strRgn & "[color=" & CreateColor(rac.Font.Color) & "]"
        End If
        stColor = rac.Font.Color
    Else
        If stNewTag Then EndStrings
    End If
End Sub

Private Function CreateColor(col As WdColor)
Dim strTmp
Select Case col
Case wdColorRed
    CreateColor = "red"
Case wdColorBlue
    CreateColor = "blue"
Case wdColorGreen
    CreateColor = "green"
Case Else
    strTmp = Hex(Not col)
    If strTmp >  6  Then
        strTmp = Right(strTmp,  6 )
    Else
    Do While Len(strTmp) <  6 
        strTmp = "0" & strTmp
    Loop
    End If
    strTmp = "#" & strTmp
    CreateColor = strTmp
End Select
End Function
...
Рейтинг: 0 / 0
29.05.2004, 15:07
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32540169
arseny
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
arseny
Участник
Привет!
 У меня Офис 2003.
Сыпется постоянно на:
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
\xa0\xa0\xa0\xa0If\xa0rac.InlineShapes.Count\xa0<>\xa00\xa0Then
\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0strRgn\xa0=\xa0strRgn\xa0&\xa0"[img="\xa0&\xa0rac.InlineShapes.Item(1).LinkFormat.SourceFullName\xa0&\xa0"]"
\xa0\xa0\xa0\xa0Else
\xa0\xa0\xa0\xa0\xa0\xa0\xa0\xa0strRgn\xa0=\xa0strRgn\xa0&\xa0rac.Text
\xa0\xa0\xa0\xa0End\xa0If
Как отформатирован этот код?
Дебаггер останавливается на:
strRgn\xa0=\xa0strRgn\xa0&\xa0"[img="\xa0&\xa0rac.InlineShapes.Item(1).LinkFormat.SourceFullName

Я его перевожу на
strRgn\xa0=\xa0strRgn\xa0&\xa0rac.Text
и получаю новый документ, но всего одна настройка и вообще никакого текста...
Ват де праблэм?
...
Рейтинг: 0 / 0
30.05.2004, 21:23
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32540269
arseny
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
arseny
Участник
Разобрался.
Я этот макрос привязал к кнопке. И так он почему то не работал.
А запустил его обычным макросом, тогда заработало.
Н о, " далеко от совершенства ". :-)
Удачи .
...
Рейтинг: 0 / 0
31.05.2004, 00:08
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32540278
arseny
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
arseny
Участник
А т ы м о ю п р о г у п р о б о в а л ? :)
...
Рейтинг: 0 / 0
31.05.2004, 00:19
| Ответить | Цитировать | Написать  
Макрос для перевода текста WORD в код для этого форума.
    #32540615
Фотография Green2
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Green2Привилегированный пользователь
Участник
2 arseny
Пробовал.

Сейчас у меня макрос такой

Вставил italic . Не могу разобраться с взаимодействием тегов, они у меня путаются.

Наверно надо взять, да и переписать его снова.
Код: plaintext
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.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
Private strRgn As String
Private stHyp As Boolean, stBolid As Boolean
Private stColor As WdColor
Private stUnderline As Boolean
Private stItalic As Boolean
Private stSize As Long
Private rac As Range
Private stNewTag As Boolean

Private Sub InitParam()
    stHyp = False
    stBolid = False
    stColor = wdColorAutomatic
    stUnderline = False
    stItalic = False
    stSize =  3 
    stNewTag = False
End Sub

Public Sub CopyToSqlRu2()
Dim doca As Document, docv As Document

strRgn = ""
InitParam

For Each rac In Selection.Characters
   RecFont
    If rac.InlineShapes.Count <>  0  Then
        strRgn = strRgn & "[img=" & rac.InlineShapes.Item( 1 ).LinkFormat.SourceFullName & "]"
    Else
        strRgn = strRgn & rac.Text
    End If
    
Next rac
    EndStrings
 'Set rna = Selection.Range
 
Set doca = ActiveDocument
Set docv = Application.Documents.Add
docv.Activate
Selection.Text = strRgn
doca.Activate

End Sub

 ' Три способа вызова функций:
 
 ' 1) Проверить на перемену тега
 
 ' 2) Вставить начало тега
 
 ' 3) Вставить конец тега
 

 ' Размер шрифта
 
Private Sub RecFont()
    If PrivSizeFont(rac.Font.Size) <> stSize Then
        If stSize <>  3  Then
            strRgn = strRgn & "[/size]"
            stSize =  3 
        End If
    End If
    If PrivSizeFont(rac.Font.Size) <> stSize Then stNewTag = True
RecLink
    If PrivSizeFont(rac.Font.Size) <> stSize Then
        If PrivSizeFont(rac.Font.Size) <>  3  Then
 '            EndStrings
 
            strRgn = strRgn & "[size=" & PrivSizeFont(rac.Font.Size) & "]"
        End If
        stSize = PrivSizeFont(rac.Font.Size)
    End If
End Sub

 ' Работа с гиперлинками
 
Private Sub RecLink()
    If rac.Hyperlinks.Count =  0  And stHyp Then
        strRgn = strRgn & ""
        stHyp = False
    End If
    If rac.Hyperlinks.Count <>  0  And Not stHyp Then stNewTag = True
    RecItalic
    If rac.Hyperlinks.Count <>  0  And Not stHyp Then
        strRgn = strRgn & "" & rac.Hyperlinks( 1 ).Address & "]"
        stHyp = True
    End If
End Sub

 ' Курсив
 
Private Sub RecItalic()
    If Not rac.Italic And stItalic Then
        strRgn = strRgn & "[/i]"
        stItalic = False
    End If
    If rac.Italic And Not stItalic Then stNewTag = True
    RecBolid
    If rac.Italic And Not stItalic Then
        strRgn = strRgn & ""
        stItalic = True
    End If
End Sub

 [i]' Жирный текст
 
Private Sub RecBolid()
    If Not rac.Bold And stBolid Then
        strRgn = strRgn & "[/b]"
        stBolid = False
    End If
    If rac.Bold And Not stBolid Then stNewTag = True
RecUnderline
    If rac.Bold And Not stBolid Then
        strRgn = strRgn & ""
        stBolid = True
    End If
End Sub


 ' Подчеркнутый текст
 
Private Sub RecUnderline()
    If rac.Underline <> wdUnderlineSingle And stUnderline Then
        strRgn = strRgn & "[/u]"
        stUnderline = False
    End If
    If rac.Underline = wdUnderlineSingle And Not stUnderline Then stNewTag = True
RecColor
    If rac.Underline = wdUnderlineSingle And Not stUnderline Then
        strRgn = strRgn & ""
        stUnderline = True
    End If
End Sub

 ' Цвет шрифта
 
Private Sub RecColor()
    If rac.Font.Color <> stColor Then
        If stColor <> wdColorAutomatic Then
            strRgn = strRgn & "[/color]"
        End If
        If stNewTag Then EndStrings
        If rac.Font.Color <> wdColorAutomatic Then
            strRgn = strRgn & "[color=" & CreateColor(rac.Font.Color) & "]"
        End If
        stColor = rac.Font.Color
    Else
        If stNewTag Then EndStrings
    End If
End Sub

Private Function PrivSizeFont(sz)
    Select Case sz
    Case Is <=  [b]5 
        PrivSizeFont =  1 
    Case  5  To  7 
        PrivSizeFont =  2 
    Case  7  To  9 
        PrivSizeFont =  3 
    Case  9  To  11 
        PrivSizeFont =  4 
    Case Is >=  11 
        PrivSizeFont =  5 
    End Select
End Function

 'Здесь находиться завершение тегов
 
Private Sub EndStrings()
    If stSize <>  3  Then strRgn = strRgn & "[/size]"
    If stHyp Then strRgn = strRgn & ""
    If stItalic Then strRgn = strRgn & "[/i]"
    If stBolid Then strRgn = strRgn & "[/b]"
    If stUnderline Then strRgn = strRgn & ""
    If stColor <> wdColorAutomatic Then strRgn = strRgn & "[/color]"
    InitParam
End Sub


Private Function CreateColor(col As WdColor)
Dim strTmp
Select Case col
Case wdColorRed
    CreateColor = "red"
Case wdColorBlue
    CreateColor = "blue"
Case wdColorGreen
    CreateColor = "green"
Case wdColorYellow
    CreateColor = "yellow"
 'Case WdColorP
 
 '    CreateColor = "purple"
 
Case wdColorOrange
    CreateColor = "orange"
Case wdColorTeal
    CreateColor = "teal"
Case wdColorBrown
    CreateColor = "brown"
 'Case wdColorGray50
 
 '    CreateColor = "gray"
 
Case Else
    strTmp = Hex(Not col)
    If strTmp >  6  Then
        strTmp = Right(strTmp,  6 )
    Else
    Do While Len(strTmp) <  6 
        strTmp = "0" & strTmp
    Loop
    End If
    strTmp = "#" & strTmp
    CreateColor = strTmp
End Select
End Function

...
Рейтинг: 0 / 0
31.05.2004, 11:06
| Ответить | Цитировать | Написать  
9 сообщений из 9, страница 1 из 1
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Макрос для перевода текста WORD в код для этого форума.
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение
NoSQL.ru       Новости, Чат       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=61&msg=32540269&tid=2186769]:
 0ms
get settings:
 8ms
get forum list:
 11ms
check forum access:
 2ms
check topic access:
 2ms
track hit:
 164ms
get topic data:
 15ms
get forum data:
 3ms
get page messages:
 59ms
get tp. blocked users:
 2ms
others: 16ms
total:  282ms
созд. / загр.: 282ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]