Mensajes

Llevas toda la razon.

Es laborioso, pero quizá merezca la pena.

Cosa de codear cada dia 1 poquito.

Salu2

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

Eso se llama troyano.

Y hay 1 subforo para eso.

Postea alli.

Salu2

explicate mejor

Creo haber entendido que quieres hacer 1 barra de progreso

Es eso lo que quieres ?

Parte 2

Código [Seleccionar] Expandir



'' 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

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

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

Aqui les hago otro regalito.

Convierte texto con formato Ritch a HTML

Que lo disfuten

Código [Seleccionar] Expandir



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 = "&nbsp;  {00}&copy;  {a9}&acute; {b4}&laquo; {ab}&raquo; {bb}&iexcl; {a1}&iquest;{bf}&Agrave;{c0}&agrave;{e0}&Aacute;{c1}"
    strCodes = strCodes & "&aacute;{e1}&Acirc; {c2}&acirc; {e2}&Atilde;{c3}&atilde;{e3}&Auml;  {c4}&auml;  {e4}&Aring; {c5}&aring; {e5}&AElig; {c6}"
    strCodes = strCodes & "&aelig; {e6}&Ccedil;{c7}&ccedil;{e7}&ETH;   {d0}&eth;   {f0}&Egrave;{c8}&egrave;{e8}&Eacute;{c9}&eacute;{e9}&Ecirc; {ca}"
    strCodes = strCodes & "&ecirc; {ea}&Euml;  {cb}&euml;  {eb}&Igrave;{cc}&igrave;{ec}&Iacute;{cd}&iacute;{ed}&Icirc; {ce}&icirc; {ee}&Iuml;  {cf}"
    strCodes = strCodes & "&iuml;  {ef}&Ntilde;{d1}&ntilde;{f1}&Ograve;{d2}&ograve;{f2}&Oacute;{d3}&oacute;{f3}&Ocirc; {d4}&ocirc; {f4}&Otilde;{d5}"
    strCodes = strCodes & "&otilde;{f5}&Ouml;  {d6}&ouml;  {f6}&Oslash;{d8}&oslash;{f8}&Ugrave;{d9}&ugrave;{f9}&Uacute;{da}&uacute;{fa}&Ucirc; {db}"
    strCodes = strCodes & "&ucirc; {fb}&Uuml;  {dc}&uuml;  {fc}&Yacute;{dd}&yacute;{fd}&yuml;  {ff}&THORN; {de}&thorn; {fe}&szlig; {df}&sect;  {a7}"
    strCodes = strCodes & "&para;  {b6}&micro; {b5}&brvbar;{a6}&plusmn;{b1}&middot;{b7}&uml;   {a8}&cedil; {b8}&ordf;  {aa}&ordm;  {ba}&not;   {ac}"
    strCodes = strCodes & "&shy;   {ad}&macr;  {af}&deg;   {b0}&sup1;  {b9}&sup2;  {b2}&sup3;  {b3}&frac14;{bc}&frac12;{bd}&frac34;{be}&times; {d7}"
    strCodes = strCodes & "&divide;{f7}&cent;  {a2}&pound; {a3}&curren;{a4}&yen;   {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 = "&#9;"   '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

Tengo problemas al postear la 2º parte.

En cuanto se resuelvan la publico.

Salu2