-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathvarios.bas
627 lines (573 loc) · 27.5 KB
/
varios.bas
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
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
Attribute VB_Name = "mVarios"
Option Explicit
Public gbMatchCase As Integer
Public gbWholeWord As Integer
Public gsFindText As String
Public gbLastPos As Integer
Public gsBuffer As String
Public glbFindSql As String
Public gsHtml As String
Public gsLastPath As String
Public glbColorizarCodigo As Boolean
Public glbRespaldarLibreria As Boolean
'carga las opciones miscelaneas
Public Sub CargaOpciones()
Dim Valor As Variant
Valor = LeeIni("opciones", "colorizar", C_INI)
If Valor <> "" Then
If Valor = 1 Then
glbColorizarCodigo = True
Else
glbColorizarCodigo = False
End If
Else
glbColorizarCodigo = True
End If
Valor = LeeIni("opciones", "respaldar", C_INI)
If Valor <> "" Then
If Valor = 1 Then
glbRespaldarLibreria = True
Else
glbRespaldarLibreria = False
End If
Else
glbRespaldarLibreria = True
End If
End Sub
'genera un archivo .html
Public Function GuardarArchivoHtml(ByVal Archivo As String, ByVal Titulo As String) As Boolean
On Local Error GoTo ErrorGuardarArchivoHtml
Dim ret As Boolean
Dim nFreeFile As Long
ret = True
nFreeFile = FreeFile
Open Archivo For Output As #nFreeFile
Print #nFreeFile, "<html>"
Print #nFreeFile, "<head><title>" & Titulo & "</title></head>"
Print #nFreeFile, "<body>"
Print #nFreeFile, gsHtml
Print #nFreeFile, "</body>"
Print #nFreeFile, "</html>"
Close #nFreeFile
GoTo SalirGuardarArchivoHtml
ErrorGuardarArchivoHtml:
ret = False
MsgBox "GuardarArchivoHtml : " & Err & " " & Error$, vbCritical
Resume SalirGuardarArchivoHtml
SalirGuardarArchivoHtml:
GuardarArchivoHtml = ret
Err = 0
End Function
Public Function RTF2HTML(strRTF As String, Optional strOptions As String, Optional strHeader As String, Optional strFooter As String) As String
'Version 2.9
'The current version of this function is available at
'http://www2.bitstream.net/~bradyh/downloads/rtf2html.zip
'More information can be found at
'http://www2.bitstream.net/~bradyh/downloads/rtf2htmlrm.html
'Converts Rich Text encoded text to HTML format
'if you find some text that this function doesn't
'convert properly please email the text to
'Options:
'+H add an HTML header and footer
'+G add a generator Metatag
'+T="MyTitle" add a title (only works if +H is used)
Dim strHTML As String
Dim l As Long
Dim lTmp As Long
Dim lTmp2 As Long
Dim lTmp3 As Long
Dim lRTFLen As Long
Dim lBOS As Long 'beginning of section
Dim lEOS As Long 'end of section
Dim strTmp As String
Dim strTmp2 As String
Dim strEOS As String 'string to be added to end of section
Dim strBOS As String 'string to be added to beginning of section
Dim strEOP As String 'string to be added to end of paragraph
Dim strBOL As String 'string to be added to the begining of each new line
Dim strEOL As String 'string to be added to the end of each new line
Dim strEOLL As String 'string to be added to the end of previous line
Dim strCurFont As String 'current font code eg: "f3"
Dim strCurFontSize As String 'current font size eg: "fs20"
Dim strCurColor As String 'current font color eg: "cf2"
Dim strFontFace As String 'Font face for current font
Dim strFontColor As String 'Font color for current font
Dim lFontSize As Integer 'Font size for current font
Const gHellFrozenOver = False 'always false
Dim gSkip As Boolean 'skip to next word/command
Dim strCodes As String 'codes for ascii to HTML char conversion
Dim strCurLine As String 'temp storage for text for current line before being added to strHTML
Dim strColorTable() As String 'table of colors
Dim lColors As Long '# of colors
Dim strFontTable() As String 'table of fonts
Dim lFonts As Long '# of fonts
Dim strFontCodes As String 'list of font code modifiers
Dim gSeekingText As Boolean 'True if we have to hit text before inserting a </FONT>
Dim gText As Boolean 'true if there is text (as opposed to a control code) in strTmp
Dim strAlign As String '"center" or "right"
Dim gAlign As Boolean 'if current text is aligned
Dim strGen As String 'Temp store for Generator Meta Tag if requested
Dim strTitle As String 'Temp store for Title if requested
'setup HTML codes
strCodes = " {00}© {a9}´ {b4}« {ab}» {bb}¡ {a1}¿{bf}À{c0}à{e0}Á{c1}"
strCodes = strCodes & "á{e1}Â {c2}â {e2}Ã{c3}ã{e3}Ä {c4}ä {e4}Å {c5}å {e5}Æ {c6}"
strCodes = strCodes & "æ {e6}Ç{c7}ç{e7}Ð {d0}ð {f0}È{c8}è{e8}É{c9}é{e9}Ê {ca}"
strCodes = strCodes & "ê {ea}Ë {cb}ë {eb}Ì{cc}ì{ec}Í{cd}í{ed}Î {ce}î {ee}Ï {cf}"
strCodes = strCodes & "ï {ef}Ñ{d1}ñ{f1}Ò{d2}ò{f2}Ó{d3}ó{f3}Ô {d4}ô {f4}Õ{d5}"
strCodes = strCodes & "õ{f5}Ö {d6}ö {f6}Ø{d8}ø{f8}Ù{d9}ù{f9}Ú{da}ú{fa}Û {db}"
strCodes = strCodes & "û {fb}Ü {dc}ü {fc}Ý{dd}ý{fd}ÿ {ff}Þ {de}þ {fe}ß {df}§ {a7}"
strCodes = strCodes & "¶ {b6}µ {b5}¦{a6}±{b1}·{b7}¨ {a8}¸ {b8}ª {aa}º {ba}¬ {ac}"
strCodes = strCodes & "­ {ad}¯ {af}° {b0}¹ {b9}² {b2}³ {b3}¼{bc}½{bd}¾{be}× {d7}"
strCodes = strCodes & "÷{f7}¢ {a2}£ {a3}¤{a4}¥ {a5}... {85}"
'setup color table
lColors = 0
ReDim strColorTable(0)
lBOS = InStr(strRTF, "\colortbl")
If lBOS <> 0 Then
lEOS = InStr(lBOS, strRTF, ";}")
If lEOS <> 0 Then
lBOS = InStr(lBOS, strRTF, "\red")
While ((lBOS <= lEOS) And (lBOS <> 0))
ReDim Preserve strColorTable(lColors)
strTmp = Trim(Hex(Mid(strRTF, lBOS + 4, 1) & IIf(IsNumeric(Mid(strRTF, lBOS + 5, 1)), Mid(strRTF, lBOS + 5, 1), "") & IIf(IsNumeric(Mid(strRTF, lBOS + 6, 1)), Mid(strRTF, lBOS + 6, 1), "")))
If Len(strTmp) = 1 Then strTmp = "0" & strTmp
strColorTable(lColors) = strColorTable(lColors) & strTmp
lBOS = InStr(lBOS, strRTF, "\green")
strTmp = Trim(Hex(Mid(strRTF, lBOS + 6, 1) & IIf(IsNumeric(Mid(strRTF, lBOS + 7, 1)), Mid(strRTF, lBOS + 7, 1), "") & IIf(IsNumeric(Mid(strRTF, lBOS + 8, 1)), Mid(strRTF, lBOS + 8, 1), "")))
If Len(strTmp) = 1 Then strTmp = "0" & strTmp
strColorTable(lColors) = strColorTable(lColors) & strTmp
lBOS = InStr(lBOS, strRTF, "\blue")
strTmp = Trim(Hex(Mid(strRTF, lBOS + 5, 1) & IIf(IsNumeric(Mid(strRTF, lBOS + 6, 1)), Mid(strRTF, lBOS + 6, 1), "") & IIf(IsNumeric(Mid(strRTF, lBOS + 7, 1)), Mid(strRTF, lBOS + 7, 1), "")))
If Len(strTmp) = 1 Then strTmp = "0" & strTmp
strColorTable(lColors) = strColorTable(lColors) & strTmp
lBOS = InStr(lBOS, strRTF, "\red")
lColors = lColors + 1
Wend
End If
End If
'setup font table
lFonts = 0
ReDim strFontTable(0)
lBOS = InStr(strRTF, "\fonttbl")
If lBOS <> 0 Then
lEOS = InStr(lBOS, strRTF, ";}}")
If lEOS <> 0 Then
lBOS = InStr(lBOS, strRTF, "\f0")
While ((lBOS <= lEOS) And (lBOS <> 0))
ReDim Preserve strFontTable(lFonts)
While ((Mid(strRTF, lBOS, 1) <> " ") And (lBOS <= lEOS))
lBOS = lBOS + 1
Wend
lBOS = lBOS + 1
strTmp = Mid(strRTF, lBOS, InStr(lBOS, strRTF, ";") - lBOS)
strFontTable(lFonts) = strFontTable(lFonts) & strTmp
lBOS = InStr(lBOS, strRTF, "\f" & (lFonts + 1))
lFonts = lFonts + 1
Wend
End If
End If
strHTML = ""
lRTFLen = Len(strRTF)
'seek first line with text on it
lBOS = InStr(strRTF, vbCrLf & "\deflang")
If lBOS = 0 Then GoTo finally Else lBOS = lBOS + 2
lEOS = InStr(lBOS, strRTF, vbCrLf & "\par")
If lEOS = 0 Then GoTo finally
While Not gHellFrozenOver
strTmp = Mid(strRTF, lBOS, lEOS - lBOS)
l = lBOS
While l <= lEOS
strTmp = Mid(strRTF, l, 1)
Select Case strTmp
Case "{"
l = l + 1
Case "}"
strCurLine = strCurLine & strEOS
strEOS = ""
l = l + 1
Case "\" 'special code
l = l + 1
strTmp = Mid(strRTF, l, 1)
Select Case strTmp
Case "b"
If ((Mid(strRTF, l + 1, 1) = " ") Or (Mid(strRTF, l + 1, 1) = "\")) Then
'b = bold
strCurLine = strCurLine & "<B>"
strEOS = "</B>" & strEOS
If (Mid(strRTF, l + 1, 1) = " ") Then l = l + 1
ElseIf (Mid(strRTF, l, 7) = "bullet ") Then
strTmp = "" 'bullet
l = l + 6
gText = True
Else
gSkip = True
End If
Case "c"
If ((Mid(strRTF, l, 2) = "cf") And (IsNumeric(Mid(strRTF, l + 2, 1)))) Then
'cf = color font
lTmp = Val(Mid(strRTF, l + 2, 5))
If lTmp <= UBound(strColorTable) Then
strCurColor = "cf" & lTmp
strFontColor = "#" & strColorTable(lTmp)
gSeekingText = True
End If
'move "cursor" position to next rtf code
lTmp = l
While ((Mid(strRTF, lTmp, 1) <> " ") And (Mid(strRTF, lTmp, 1) <> "\"))
lTmp = lTmp + 1
Wend
If (Mid(strRTF, lTmp, 1) = " ") Then
l = lTmp
Else
l = lTmp - 1
End If
Else
gSkip = True
End If
Case "e"
If (Mid(strRTF, l, 7) = "emdash ") Then
strTmp = ""
l = l + 6
gText = True
Else
gSkip = True
End If
Case "f"
If IsNumeric(Mid(strRTF, l + 1, 1)) Then
'f# = font
'first get font number
lTmp = l + 2
strTmp2 = Mid(strRTF, l + 1, 1)
While IsNumeric(Mid(strRTF, lTmp, 1))
strTmp2 = strTmp2 & Mid(strRTF, lTmp2, 1)
lTmp = lTmp + 1
Wend
lTmp = Val(strTmp2)
strCurFont = "f" & lTmp
If ((lTmp <= UBound(strFontTable)) And (strFontTable(lTmp) <> strFontTable(0))) Then
'insert codes if lTmp is a valid font # AND the font is not the default font
strFontFace = strFontTable(lTmp)
gSeekingText = True
End If
'move "cursor" position to next rtf code
lTmp = l
While ((Mid(strRTF, lTmp, 1) <> " ") And (Mid(strRTF, lTmp, 1) <> "\"))
lTmp = lTmp + 1
Wend
If (Mid(strRTF, lTmp, 1) = " ") Then
l = lTmp
Else
l = lTmp - 1
End If
ElseIf ((Mid(strRTF, l + 1, 1) = "s") And (IsNumeric(Mid(strRTF, l + 2, 1)))) Then
'fs# = font size
'first get font size
lTmp = l + 3
strTmp2 = Mid(strRTF, l + 2, 1)
While IsNumeric(Mid(strRTF, lTmp, 1))
strTmp2 = strTmp2 & Mid(strRTF, lTmp, 1)
lTmp = lTmp + 1
Wend
lTmp = Val(strTmp2)
strCurFontSize = "fs" & lTmp
lFontSize = Int((lTmp / 5) - 2)
If lFontSize = 2 Then
strCurFontSize = ""
lFontSize = 0
Else
gSeekingText = True
If lFontSize > 8 Then lFontSize = 8
If lFontSize < 1 Then lFontSize = 1
End If
'move "cursor" position to next rtf code
lTmp = l
While ((Mid(strRTF, lTmp, 1) <> " ") And (Mid(strRTF, lTmp, 1) <> "\"))
lTmp = lTmp + 1
Wend
If (Mid(strRTF, lTmp, 1) = " ") Then
l = lTmp
Else
l = lTmp - 1
End If
Else
gSkip = True
End If
Case "i"
If ((Mid(strRTF, l + 1, 1) = " ") Or (Mid(strRTF, l + 1, 1) = "\")) Then
strCurLine = strCurLine & "<I>"
strEOS = "</I>" & strEOS
If (Mid(strRTF, l + 1, 1) = " ") Then l = l + 1
Else
gSkip = True
End If
Case "l"
If (Mid(strRTF, l, 10) = "ldblquote ") Then
'left doublequote
strTmp = ""
l = l + 9
gText = True
ElseIf (Mid(strRTF, l, 7) = "lquote ") Then
'left quote
strTmp = ""
l = l + 6
gText = True
Else
gSkip = True
End If
Case "p"
If ((Mid(strRTF, l, 6) = "plain\") Or (Mid(strRTF, l, 6) = "plain ")) Then
If (Len(strFontColor & strFontFace) > 0) Then
If Not gSeekingText Then strCurLine = strCurLine & "</FONT>"
strFontColor = ""
strFontFace = ""
End If
If gAlign Then
strCurLine = strCurLine & "</TD></TR></TABLE><BR>"
gAlign = False
End If
strCurLine = strCurLine & strEOS
strEOS = ""
If Mid(strRTF, l + 5, 1) = "\" Then l = l + 4 Else l = l + 5 'catch next \ but skip a space
ElseIf (Mid(strRTF, l, 9) = "pnlvlblt\") Then
'bulleted list
strEOS = ""
strBOS = "<UL>"
strBOL = "<LI>"
strEOL = "</LI>"
strEOP = "</UL>"
l = l + 7 'catch next \
ElseIf (Mid(strRTF, l, 7) = "pntext\") Then
l = InStr(l, strRTF, "}") 'skip to end of braces
ElseIf (Mid(strRTF, l, 6) = "pntxtb") Then
l = InStr(l, strRTF, "}") 'skip to end of braces
ElseIf (Mid(strRTF, l, 10) = "pard\plain") Then
strCurLine = strCurLine & strEOS & strEOP
strEOS = ""
strEOP = ""
strBOL = ""
strEOL = "<BR>"
l = l + 3 'catch next \
Else
gSkip = True
End If
Case "q"
If ((Mid(strRTF, l, 3) = "qc\") Or (Mid(strRTF, l, 3) = "qc ")) Then
'qc = centered
strAlign = "center"
'move "cursor" position to next rtf code
If (Mid(strRTF, l + 2, 1) = " ") Then l = l + 2
l = l + 1
ElseIf ((Mid(strRTF, l, 3) = "qr\") Or (Mid(strRTF, l, 3) = "qr ")) Then
'qr = right justified
strAlign = "right"
'move "cursor" position to next rtf code
If (Mid(strRTF, l + 2, 1) = " ") Then l = l + 2
l = l + 1
Else
gSkip = True
End If
Case "r"
If (Mid(strRTF, l, 7) = "rquote ") Then
'reverse quote
strTmp = ""
l = l + 6
gText = True
ElseIf (Mid(strRTF, l, 10) = "rdblquote ") Then
'reverse doublequote
strTmp = ""
l = l + 9
gText = True
Else
gSkip = True
End If
Case "s"
'strikethrough
If ((Mid(strRTF, l, 7) = "strike\") Or (Mid(strRTF, l, 7) = "strike ")) Then
strCurLine = strCurLine & "<STRIKE>"
strEOS = "</STRIKE>" & strEOS
l = l + 6
Else
gSkip = True
End If
Case "t"
If (Mid(strRTF, l, 4) = "tab ") Then
strTmp = "	" 'tab
l = l + 2
gText = True
Else
gSkip = True
End If
Case "u"
'underline
If ((Mid(strRTF, l, 3) = "ul ") Or (Mid(strRTF, l, 3) = "ul\")) Then
strCurLine = strCurLine & "<U>"
strEOS = "</U>" & strEOS
l = l + 1
Else
gSkip = True
End If
Case "'"
'special characters
strTmp2 = "{" & Mid(strRTF, l + 1, 2) & "}"
lTmp = InStr(strCodes, strTmp2)
If lTmp = 0 Then
strTmp = Chr("&H" & Mid(strTmp2, 2, 2))
Else
strTmp = Trim(Mid(strCodes, lTmp - 8, 8))
End If
l = l + 1
gText = True
Case "~"
strTmp = " "
gText = True
Case "{", "}", "\"
gText = True
Case vbLf, vbCr, vbCrLf 'always use vbCrLf
strCurLine = strCurLine & vbCrLf
Case Else
gSkip = True
End Select
If gSkip = True Then
'skip everything up until the next space or "\" or "}"
While InStr(" \}", Mid(strRTF, l, 1)) = 0
l = l + 1
Wend
gSkip = False
If (Mid(strRTF, l, 1) = "\") Then l = l - 1
End If
l = l + 1
Case vbLf, vbCr, vbCrLf
l = l + 1
Case Else
gText = True
End Select
If gText Then
If ((Len(strFontColor & strFontFace) > 0) And gSeekingText) Then
If Len(strAlign) > 0 Then
gAlign = True
If strAlign = "center" Then
strCurLine = strCurLine & "<TABLE ALIGN=""left"" CELLSPACING=0 CELLPADDING=0 WIDTH=""100%""><TR ALIGN=""center""><TD>"
ElseIf strAlign = "right" Then
strCurLine = strCurLine & "<TABLE ALIGN=""left"" CELLSPACING=0 CELLPADDING=0 WIDTH=""100%""><TR ALIGN=""right""><TD>"
End If
strAlign = ""
End If
If Len(strFontFace) > 0 Then
strFontCodes = strFontCodes & " FACE=" & strFontFace
End If
If Len(strFontColor) > 0 Then
strFontCodes = strFontCodes & " COLOR=" & strFontColor
End If
If Len(strCurFontSize) > 0 Then
strFontCodes = strFontCodes & " SIZE = " & lFontSize
End If
strCurLine = strCurLine & "<FONT" & strFontCodes & ">"
strFontCodes = ""
End If
strCurLine = strCurLine & strTmp
l = l + 1
gSeekingText = False
gText = False
End If
Wend
lBOS = lEOS + 2
lEOS = InStr(lEOS + 1, strRTF, vbCrLf & "\par")
strHTML = strHTML & strEOLL & strBOS & strBOL & strCurLine & vbCrLf
strEOLL = strEOL
If Len(strEOL) = 0 Then strEOL = "<BR>"
If lEOS = 0 Then GoTo finally
strBOS = ""
strCurLine = ""
Wend
finally:
strHTML = strHTML & strEOS
'clear up any hanging fonts
If (Len(strFontColor & strFontFace) > 0) Then strHTML = strHTML & "</FONT>" & vbCrLf
'Add Generator Metatag if requested
If InStr(strOptions, "+G") <> 0 Then
strGen = "<META NAME=""GENERATOR"" CONTENT=""RTF2HTML by Brady Hegberg"">"
Else
strGen = ""
End If
'Add Title if requested
If InStr(strOptions, "+T") <> 0 Then
lTmp = InStr(strOptions, "+T") + 3
lTmp2 = InStr(lTmp + 1, strOptions, """")
strTitle = Mid(strOptions, lTmp, lTmp2 - lTmp)
Else
strTitle = ""
End If
'add header and footer if requested
If InStr(strOptions, "+H") <> 0 Then strHTML = strHeader & vbCrLf _
& strHTML _
& strFooter
RTF2HTML = strHTML
End Function
Sub FindText()
On Local Error GoTo SalirFindText
Dim lWhere, lPos As Long
Dim sTmp As String
Dim Sql As String
Sql = UCase$(glbFindSql)
If gbLastPos = 0 Or gbLastPos > Len(Sql) Then
lPos = 1
Else
lPos = gbLastPos
End If
Do While lPos < Len(Sql)
sTmp = Mid(Sql, lPos, Len(Sql))
lWhere = InStr(sTmp, UCase$(gsFindText))
lPos = lPos + lWhere
If lWhere Then ' If found,
frmMain.SetFocus
frmMain.rtbCodigo.SelStart = lPos - 2 ' set selection start and
frmMain.rtbCodigo.SelLength = Len(gsFindText) ' set selection length. Else
gbLastPos = lPos
Exit Do
Else
gbLastPos = 0
Exit Do 'we are ready
End If
Loop
Exit Sub
SalirFindText:
gbLastPos = 0
Err = 0
End Sub
Function EmptyString(ByRef sText As String) As Boolean
If IsNull(sText) Then
EmptyString = True
Else
EmptyString = (Len(Trim(sText)) = 0)
End If
End Function
Function AttachPath(sFileName As String, sPath As String) As String
If Len(Trim(ExtractPath(sFileName))) = 0 Then
AttachPath = FixPath(sPath) & sFileName
Else
AttachPath = sFileName
End If
End Function
Function FixPath(ByVal sPath As String) As String
If Len(Trim(sPath)) = 0 Then
FixPath = ""
ElseIf Right$(sPath, 1) <> "\" Then
FixPath = sPath & "\"
Else
FixPath = sPath
End If
End Function
Public Function StripNulls(OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
StripNulls = OriginalStr
End Function
Public Sub Copiar(ByVal hWnd As Long)
Dim ret As Long
ret = SendMessage(hWnd, WM_COPY, 0, 0)
End Sub
Public Function Confirma(ByVal Msg As String) As Integer
Confirma = MsgBox(Msg, vbQuestion + vbYesNo + vbDefaultButton2)
End Function