| |
|
72
|
Programación / Programación Visual Basic / Re: Juegos programados en vb??
|
en: 26 Mayo 2006, 04:25 am
|
|
Se pueden hacer juegos tipo diablo II en VB.
Yo poseo 1 Source que lo confirma.
Es 1 PDF llamado
Thomson,.Microsoft.Visual.Basic.Game.Programming.for.Teen.pdf
(creo Recordar)
El tema es que Vb no explota bien los recursos gráficos, aceleración 3D, etc
Ademas, presenta la limitacion de las librerias de Run-Time
Más claro, que VB no esta preparado para desarrollar juegos tanto en cantidad de codigo como en eficiencia del mismo.
No obstante, les recomiendo que miren este PDF aprenderan bastante.
Intentare subirlo a la sección de Manuales. Sino puedo busquenlo en Emule, yo lo encontre ahi.
Esten atentos.
Salu2
|
|
|
|
|
76
|
Programación / Programación Visual Basic / Re: Declaraciones Modulo de OBDC 32 bits
|
en: 26 Mayo 2006, 00:25 am
|
Parte 2
'' modulo OBDC
'' Parte 2
' Scroll option masks
Global Const SQL_SO_FORWARD_ONLY As Long = &H1&
Global Const SQL_SO_KEYSET_DRIVEN As Long = &H2&
Global Const SQL_SO_DYNAMIC As Long = &H4&
Global Const SQL_SO_MIXED As Long = &H8&
Global Const SQL_SO_STATIC As Long = &H10&
' Scroll concurrency option masks
Global Const SQL_SCCO_READ_ONLY As Long = &H1&
Global Const SQL_SCCO_LOCK As Long = &H2&
Global Const SQL_SCCO_OPT_ROWVER As Long = &H4&
Global Const SQL_SCCO_OPT_VALUES As Long = &H8&
' Fetch direction option masks
Global Const SQL_FD_FETCH_NEXT As Long = &H1&
Global Const SQL_FD_FETCH_FIRST As Long = &H2&
Global Const SQL_FD_FETCH_LAST As Long = &H4&
Global Const SQL_FD_FETCH_PRIOR As Long = &H8&
Global Const SQL_FD_FETCH_ABSOLUTE As Long = &H10&
Global Const SQL_FD_FETCH_RELATIVE As Long = &H20&
Global Const SQL_FD_FETCH_RESUME As Long = &H40&
Global Const SQL_FD_FETCH_BOOKMARK As Long = &H80&
' Transaction isolation option masks
Global Const SQL_TXN_READ_UNCOMMITTED As Long = &H1&
Global Const SQL_TXN_READ_COMMITTED As Long = &H2&
Global Const SQL_TXN_REPEATABLE_READ As Long = &H4&
Global Const SQL_TXN_SERIALIZABLE As Long = &H8&
Global Const SQL_TXN_VERSIONING As Long = &H10&
' Correlation name
Global Const SQL_CN_NONE As Long = 0
Global Const SQL_CN_DIFFERENT As Long = 1
Global Const SQL_CN_ANY As Long = 2
' Non-nullable columns
Global Const SQL_NNC_NULL As Long = 0
Global Const SQL_NNC_NON_NULL As Long = 1
' Null collation
Global Const SQL_NC_HIGH As Long = 0
Global Const SQL_NC_LOW As Long = 1
Global Const SQL_NC_START As Long = 2
Global Const SQL_NC_END As Long = 4
' File usage
Global Const SQL_FILE_NOT_SUPPORTED As Long = 0
Global Const SQL_FILE_TABLE As Long = 1
Global Const SQL_FILE_QUALIFIER As Long = 2
' SQLGetData extensions masks
Global Const SQL_GD_ANY_COLUMN As Long = &H1&
Global Const SQL_GD_ANY_ORDER As Long = &H2&
Global Const SQL_GD_BLOCK As Long = &H4&
Global Const SQL_GD_BOUND As Long = &H8&
' Alter table
Global Const SQL_AT_ADD_COLUMN As Long = 1
Global Const SQL_AT_DROP_COLUMN As Long = 2
' Positioned statements masks
Global Const SQL_PS_POSITIONED_DELETE As Long = &H1&
Global Const SQL_PS_POSITIONED_UPDATE As Long = &H2&
Global Const SQL_PS_SELECT_FOR_UPDATE As Long = &H4&
' Group By
Global Const SQL_GB_NOT_SUPPORTED As Long = 0
Global Const SQL_GB_GROUP_BY_EQUALS_SELECT As Long = 1
Global Const SQL_GB_GROUP_BY_CONTAINS_SELECT As Long = 2
Global Const SQL_GB_NO_RELATION As Long = 3
' Owner usage masks
Global Const SQL_OU_DML_STATEMENTS As Long = &H1&
Global Const SQL_OU_PROCEDURE_INVOCATION As Long = &H2&
Global Const SQL_OU_TABLE_DEFINITION As Long = &H4&
Global Const SQL_OU_INDEX_DEFINITION As Long = &H8&
Global Const SQL_OU_PRIVILEGE_DEFINITION As Long = &H10&
' Qualifier usage masks
Global Const SQL_QU_DML_STATEMENTS As Long = &H1&
Global Const SQL_QU_PROCEDURE_INVOCATION As Long = &H2&
Global Const SQL_QU_TABLE_DEFINITION As Long = &H4&
Global Const SQL_QU_INDEX_DEFINITION As Long = &H8&
Global Const SQL_QU_PRIVILEGE_DEFINITION As Long = &H10&
' Subqueries masks
Global Const SQL_SQ_COMPARISON As Long = &H1&
Global Const SQL_SQ_EXISTS As Long = &H2&
Global Const SQL_SQ_IN As Long = &H4&
Global Const SQL_SQ_QUANTIFIED As Long = &H8&
Global Const SQL_SQ_CORRELATED_SUBQUERIES As Long = &H10&
' Union masks
Global Const SQL_U_UNION As Long = &H1&
Global Const SQL_U_UNION_ALL As Long = &H2&
' Bookmark persistence
Global Const SQL_BP_CLOSE As Long = &H1&
Global Const SQL_BP_DELETE As Long = &H2&
Global Const SQL_BP_DROP As Long = &H4&
Global Const SQL_BP_TRANSACTION As Long = &H8&
Global Const SQL_BP_UPDATE As Long = &H10&
Global Const SQL_BP_OTHER_HSTMT As Long = &H20&
Global Const SQL_BP_SCROLL As Long = &H40&
' Static sensitivity
Global Const SQL_SS_ADDITIONS As Long = &H1&
Global Const SQL_SS_DELETIONS As Long = &H2&
Global Const SQL_SS_UPDATES As Long = &H4&
' Lock types masks
Global Const SQL_LCK_NO_CHANGE As Long = &H1&
Global Const SQL_LCK_EXCLUSIVE As Long = &H2&
Global Const SQL_LCK_UNLOCK As Long = &H4&
' Positioned operations masks
Global Const SQL_POS_POSITION As Long = &H1&
Global Const SQL_POS_REFRESH As Long = &H2&
Global Const SQL_POS_UPDATE As Long = &H4&
Global Const SQL_POS_DELETE As Long = &H8&
Global Const SQL_POS_ADD As Long = &H10&
' Qualifier location
Global Const SQL_QL_START As Long = 1
Global Const SQL_QL_END As Long = 2
' Options for SQLGetStmtOption/SQLSetStmtOption
Global Const SQL_QUERY_TIMEOUT As Long = 0
Global Const SQL_MAX_ROWS As Long = 1
Global Const SQL_NOSCAN As Long = 2
Global Const SQL_MAX_LENGTH As Long = 3
Global Const SQL_ASYNC_ENABLE As Long = 4
Global Const SQL_BIND_TYPE As Long = 5
Global Const SQL_CURSOR_TYPE As Long = 6
Global Const SQL_CONCURRENCY As Long = 7
Global Const SQL_KEYSET_SIZE As Long = 8
Global Const SQL_ROWSET_SIZE As Long = 9
Global Const SQL_SIMULATE_CURSOR As Long = 10
Global Const SQL_RETRIEVE_DATA As Long = 11
Global Const SQL_USE_BOOKMARKS As Long = 12
Global Const SQL_GET_BOOKMARK As Long = 13
Global Const SQL_ROW_NUMBER As Long = 14
Global Const SQL_STMT_OPT_MAX As Long = SQL_ROW_NUMBER
' Statement option values & defaults
Global Const SQL_QUERY_TIMEOUT_DEFAULT As Long = 0
Global Const SQL_MAX_ROWS_DEFAULT As Long = 0
Global Const SQL_NOSCAN_OFF As Long = 0
Global Const SQL_NOSCAN_ON As Long = 1
Global Const SQL_NOSCAN_DEFAULT As Long = SQL_NOSCAN_OFF
Global Const SQL_MAX_LENGTH_DEFAULT As Long = 0
Global Const SQL_ASYNC_ENABLE_OFF As Long = 0
Global Const SQL_ASYNC_ENABLE_ON As Long = 1
Global Const SQL_ASYNC_ENABLE_DEFAULT As Long = SQL_ASYNC_ENABLE_OFF
Global Const SQL_BIND_BY_COLUMN As Long = 0
Global Const SQL_CONCUR_READ_ONLY As Long = 1
Global Const SQL_CONCUR_LOCK As Long = 2
Global Const SQL_CONCUR_ROWVER As Long = 3
Global Const SQL_CONCUR_VALUES As Long = 4
Global Const SQL_CURSOR_FORWARD_ONLY As Long = 0
Global Const SQL_CURSOR_KEYSET_DRIVEN As Long = 1
Global Const SQL_CURSOR_DYNAMIC As Long = 2
Global Const SQL_CURSOR_STATIC As Long = 3
Global Const SQL_ROWSET_SIZE_DEFAULT As Long = 1
Global Const SQL_KEYSET_SIZE_DEFAULT As Long = 0
Global Const SQL_SC_NON_UNIQUE As Long = 0
Global Const SQL_SC_TRY_UNIQUE As Long = 1
Global Const SQL_SC_UNIQUE As Long = 2
Global Const SQL_RD_OFF As Long = 0
Global Const SQL_RD_ON As Long = 1
Global Const SQL_RD_DEFAULT As Long = SQL_RD_ON
Global Const SQL_UB_OFF As Long = 0
Global Const SQL_UB_ON As Long = 1
Global Const SQL_UB_DEFAULT As Long = SQL_UB_ON
' Options for SQLSetConnectOption/SQLGetConnectOption
Global Const SQL_ACCESS_MODE As Long = 101
Global Const SQL_AUTOCOMMIT As Long = 102
Global Const SQL_LOGIN_TIMEOUT As Long = 103
Global Const SQL_OPT_TRACE As Long = 104
Global Const SQL_OPT_TRACEFILE As Long = 105
Global Const SQL_TRANSLATE_DLL As Long = 106
Global Const SQL_TRANSLATE_OPTION As Long = 107
Global Const SQL_TXN_ISOLATION As Long = 108
Global Const SQL_CURRENT_QUALIFIER As Long = 109
Global Const SQL_CONNECT_OPT_DRVR_START As Long = 1000
Global Const SQL_ODBC_CURSORS As Long = 110
Global Const SQL_QUIET_MODE As Long = 111
Global Const SQL_PACKET_SIZE As Long = 112
Global Const SQL_CONN_OPT_MAX As Long = SQL_PACKET_SIZE
Global Const SQL_CONN_OPT_MIN As Long = SQL_ACCESS_MODE
' Access mode options
Global Const SQL_MODE_READ_WRITE As Long = 0
Global Const SQL_MODE_READ_ONLY As Long = 1
Global Const SQL_MODE_DEFAULT As Long = SQL_MODE_READ_WRITE
' Autocommit options
Global Const SQL_AUTOCOMMIT_OFF As Long = 0
Global Const SQL_AUTOCOMMIT_ON As Long = 1
Global Const SQL_AUTOCOMMIT_DEFAULT As Long = SQL_AUTOCOMMIT_ON
' Login timeout options
Global Const SQL_LOGIN_TIMEOUT_DEFAULT As Long = 15
' Trace options
Global Const SQL_OPT_TRACE_OFF As Long = 0
Global Const SQL_OPT_TRACE_ON As Long = 1
Global Const SQL_OPT_TRACE_DEFAULT As Long = SQL_OPT_TRACE_OFF
Global Const SQL_OPT_TRACE_FILE_DEFAULT = "\\SQL.LOG"
' Cursor options
Global Const SQL_CUR_USE_IF_NEEDED As Long = 0
Global Const SQL_CUR_USE_ODBC As Long = 1
Global Const SQL_CUR_USE_DRIVER As Long = 2
Global Const SQL_CUR_DEFAULT As Long = SQL_CUR_USE_DRIVER
' Column types and scopes in SQLSpecialColumns.
Global Const SQL_BEST_ROWID As Long = 1
Global Const SQL_ROWVER As Long = 2
Global Const SQL_SCOPE_CURROW As Long = 0
Global Const SQL_SCOPE_TRANSACTION As Long = 1
Global Const SQL_SCOPE_SESSION As Long = 2
' Level 2 Functions
' SQLExtendedFetch "fFetchType" values
Global Const SQL_FETCH_NEXT As Long = 1
Global Const SQL_FETCH_FIRST As Long = 2
Global Const SQL_FETCH_LAST As Long = 3
Global Const SQL_FETCH_PRIOR As Long = 4
Global Const SQL_FETCH_ABSOLUTE As Long = 5
Global Const SQL_FETCH_RELATIVE As Long = 6
Global Const SQL_FETCH_BOOKMARK As Long = 8
' SQLExtendedFetch "rgfRowStatus" element values
Global Const SQL_ROW_SUCCESS As Long = 0
Global Const SQL_ROW_DELETED As Long = 1
Global Const SQL_ROW_UPDATED As Long = 2
Global Const SQL_ROW_NOROW As Long = 3
Global Const SQL_ROW_ADDED As Long = 4
Global Const SQL_ROW_ERROR As Long = 5
' Defines for SQLForeignKeys (returned in result set)
Global Const SQL_CASCADE As Long = 0
Global Const SQL_RESTRICT As Long = 1
Global Const SQL_SET_NULL As Long = 2
' Defines for SQLProcedureColumns (returned in the result set)
Global Const SQL_PARAM_TYPE_UNKNOWN As Long = 0
Global Const SQL_PARAM_INPUT As Long = 1
Global Const SQL_PARAM_INPUT_OUTPUT As Long = 2
Global Const SQL_RESULT_COL As Long = 3
Global Const SQL_PARAM_OUTPUT As Long = 4
' Defines for SQLStatistics
Global Const SQL_INDEX_UNIQUE As Long = 0
Global Const SQL_INDEX_ALL As Long = 1
Global Const SQL_ENSURE As Long = 1
Global Const SQL_QUICK As Long = 0
' Defines for SQLStatistics (returned in the result set)
Global Const SQL_TABLE_STAT As Long = 0
Global Const SQL_INDEX_CLUSTERED As Long = 1
Global Const SQL_INDEX_HASHED As Long = 2
Global Const SQL_INDEX_OTHER As Long = 3
' Procedures
Global Const SQL_PT_UNKNOWN As Long = 0
Global Const SQL_PT_PROCEDURE As Long = 1
Global Const SQL_PT_FUNCTION As Long = 2
' Procedure columns
Global Const SQL_PC_UNKNOWN As Long = 0
Global Const SQL_PC_NON_PSEUDO As Long = 1
Global Const SQL_PC_PSEUDO As Long = 2
' Defines for SQLSetPos
Global Const SQL_ENTIRE_ROWSET As Long = 0
Global Const SQL_POSITION As Long = 0
Global Const SQL_REFRESH As Long = 1
Global Const SQL_UPDATE As Long = 2
Global Const SQL_DELETE As Long = 3
Global Const SQL_ADD As Long = 4
' Lock options
Global Const SQL_LOCK_NO_CHANGE As Long = 0
Global Const SQL_LOCK_EXCLUSIVE As Long = 1
Global Const SQL_LOCK_UNLOCK As Long = 2
' Deprecated global constants
Global Const SQL_DATABASE_NAME As Long = 16
Global Const SQL_FD_FETCH_PREV As Long = SQL_FD_FETCH_PRIOR
Global Const SQL_FETCH_PREV As Long = SQL_FETCH_PRIOR
Global Const SQL_CONCUR_TIMESTAMP As Long = SQL_CONCUR_ROWVER
Global Const SQL_SCCO_OPT_TIMESTAMP As Long = SQL_SCCO_OPT_ROWVER
Global Const SQL_CC_DELETE As Long = SQL_CB_DELETE
Global Const SQL_CR_DELETE As Long = SQL_CB_DELETE
Global Const SQL_CC_CLOSE As Long = SQL_CB_CLOSE
Global Const SQL_CR_CLOSE As Long = SQL_CB_CLOSE
Global Const SQL_CC_PRESERVE As Long = SQL_CB_PRESERVE
Global Const SQL_CR_PRESERVE As Long = SQL_CB_PRESERVE
Global Const SQL_FETCH_RESUME As Long = 7
Global Const SQL_SCROLL_FORWARD_ONLY As Long = 0
Global Const SQL_SCROLL_KEYSET_DRIVEN As Long = -1
Global Const SQL_SCROLL_DYNAMIC As Long = -2
Global Const SQL_SCROLL_STATIC As Long = -3
#End If 'Win32
Que lo disfruten Salu2 |
|
|
|
|
77
|
Programación / Programación Visual Basic / Re: Evitar ejecucion de programa.
|
en: 26 Mayo 2006, 00:19 am
|
|
Si restringes el uso de una clase, al abrirse el proceso ve que la clase no esta permitida y se cierra normal, sin dar error.
Aunque tambien se puede hacer que de error con una API.
Para ver las clases, el programa tiene que estar en ejecución y tienes que verlas 1 programa especial.
Se llama Spy++ y monitoriza todos los elementos que hay corriendo permitiendo mandarle mensajes LPARAM y WPARAM. Esta utilidad la trae VB edicion Enterprise, (no estoy seguro que la traiga otras versiones. Yo tengo la Enter
Tambien puedes buscar las clases por internet, pero yo lo hago de la forma que te dije antes, debido a que segun la versión del Software (el programa instalado) algunas cambian de clase y porque asi, se las que necesito.
Las clases de Windows y otras aplicaciones, no se pueden modificar. Solo en el caso de inyeccion (creo) y solo se modifican en memoria y en tiempo de ejecucion.
La clase y Subclases de una aplicación, es como un identificador´"físico" que el S.O. utiliza para saber que esta ahi, aparte de gestionar los eventos, métodos, funciones, etc
Lee 1 poco del tema, y animate a hacer clases propias.
Tras conocer clases te podras meter en Herencia y Polimorfismo.
Salu2
|
|
|
|
|
78
|
Programación / Programación Visual Basic / Re: Evitar ejecucion de programa.
|
en: 25 Mayo 2006, 15:38 pm
|
|
Gorky, mira es sencillo.
Evidentemente, si restringes el uso de una clase, todas las aplicaciones que la usen no funcionarán o funcionarán parcialmente.
Una clase es como un módulo .BAS solo que tiiene extension .CLS
La diferencia entre ambas es que el módulo .BAS contiene funciones, procedimientos y contstantes que tu aplicación puede usar.
Mientras que el modulo de clase .CLS estan todos los procedimientos, funciones, métodos y propiedades que ese objeto posee.
El S.O. las contiene en alguna DLL pero no se en cual.
Un ejemplo para que lo entiendas.
Ya has estado trabajando con clases.
Cuando añades 1 form nuevo al proyecto, tienes disponibles las propiedades Name, Caption, Appearance, etc
Y tambien los métodos Show, Hide, Move, Refresh, etc
Estas propiedades y métodos estan almacenados en una clase llamada ThunderRT6Main.
Si creas 1 aplicacion con 1 form y 1 commandbutton para salir de ella, al ver las clases que usa el proyecto, te saldran
las clases ThunderRT6Main y ThunderRT6Commandbutton.
VB nos permite desarrollar clases propias con eventos, métodos, propiedades, etc o mejorar las existentes
Espero haberte ayudado
Salu2
|
|
|
|
|
79
|
Programación / Programación Visual Basic / Modulo RTF to HTML
|
en: 25 Mayo 2006, 05:58 am
|
Aqui les hago otro regalito. Convierte texto con formato Ritch a HTML Que lo disfuten
Function RTF2HTML(strRTF As String, Optional strOptions As String, Optional strHeader As String, Optional strFooter As String) As String
'Version 2.9
'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
'bradyh@bitstream.net
'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
Salu2 |
|
|
|
|
|
| |
|
Mostrar Mensajes
