Club Delphi  
    FTP   CCD     Buscar   Trucos   Trabajo   Foros

Retroceder   Foros Club Delphi > Principal > Varios
Registrarse FAQ Miembros Calendario Guía de estilo Buscar Temas de Hoy Marcar Foros Como Leídos

Grupo de Teaming del ClubDelphi

Respuesta
 
Herramientas Buscar en Tema Desplegado
  #1  
Antiguo 08-10-2018
DarkSton DarkSton is offline
Miembro
 
Registrado: jun 2017
Posts: 64
Poder: 7
DarkSton Va por buen camino
Red face pasar este codigo vb 6.0 a delphi7

me pueden ayudar a pasar ese codigo a delphi7,esto es un edito hecho en visual basic 6.0
Código PHP:
Private Declare Function LogonUser Lib "advapi32" Alias "LogonUserA" (ByVal lpszUsername As StringByVal lpszDomain As StringByVal lpszPassword As StringByVal dwLogonType As LongByVal dwLogonProvider As LongphToken As Long) As Long
Private Declare Function ImpersonateLoggedOnUser Lib "advapi32" (ByVal hToken As Long) As Long


Private Type StructAvatars
   
//AvContador As String * 4
    
AvNoMenu As String 4
    
    AvNoImg 
As String 4
    
    AvNew 
As String 1
    AvNew0 
As String 3
    
    AvName 
As String 20
    
    AvVisible0 
As String 3
    AvVisible 
As String 1
    
    AvUnknow 
As String 1
    
    AvActWeek 
As String 1
    AvActWeek0 
As String 2
    AvPriceWeekG 
As String 4
    AvPriceWeekC 
As String 4
    
    AvActN1 
As String 1
    AvActN10 
As String 3
    AvPriceN1G 
As String 4
    AvPriceN1C 
As String 4
    
    AvActMonth 
As String 1
    AvActMonth0 
As String 3
    AvPriceMonthG 
As String 4
    AvPriceMonthC 
As String 4
    
    AvActN2 
As String 1
    AvActN20 
As String 3
    AvPriceN2G 
As String 4
    AvPriceN2C 
As String 4
    
    AvActIlimit 
As String 1
    AvActIlimit0 
As String 3
    AvPriceIlimitG 
As String 4
    AvPriceIlimitC 
As String 4
    
    AvActGold 
As String 1
    AvActCash 
As String 1
    AvGoldCash0 
As String 2
    
    AvSDelay 
As String 1
    AvSDelay0 
As String 3
    AvBunge 
As String 1
    AvBunge0 
As String 3
    AvAttack 
As String 1
    AvAttack0 
As String 3
    AvDefense 
As String 1
    AvDefense0 
As String 3
    AvHealt 
As String 1
    AvHealt0 
As String 3
    AvIDelay 
As String 1
    AvIDelay0 
As String 3
    AvShield 
As String 1
    AvShield0 
As String 3
    AvPopularity 
As String 1
    AvPopularity0 
As String 3
    
    AvDescription 
As String 64
        
    AvSepara 
As String 448
    
End Type

Dim FileFree 
As Integer
Dim FileTemp 
As Integer
Dim RegActual 
As Long
Dim RegUltimo 
As Long
Dim RegActualTemp 
As Long
Dim Pos 
As IntegerAs Integer
Dim Datos 
As StructAvatars
Dim DatosTemp 
As StructAvatars

Private Sub cmdAnterior_Click()
If 
RegActual 1 Then
    MsgBox 
" Primer registro "vbInformation
Else
    
'Diminuir a variável que mantém a posição do registro atual
    RegActual = RegActual - 1
    '
Mostramos os dados nas caixas de texto
    VisualizarDatos
End 
If
End Sub


Private Sub cmdGuardar_Click()
    
GuardarDatos
End Sub
Private Sub GuardarDatos()

'Atribuir estrutura de dados com o conteúdo do textBox
With Datos

    .AvNoMenu = txtToSave(txtAvNoMenu.Text)
    
    .AvNoImg = txtToSave(txtAvNoImg.Text)
    
    If chkAvNew.Value = 1 Then
        .AvNew = HexToString("01")
    Else
        .AvNew = HexToString("00")
    End If
    
    .AvNew0 = NullByte("0", 3)
    
    .AvName = txtAvName + NullByte("0", Len(.AvName) - Len(txtAvName))
    
    .AvVisible0 = NullByte("0", 3)
    
    If chkAvVisible.Value = 1 Then
        .AvVisible = HexToString("01")
    Else
        .AvVisible = HexToString("00")
    End If
    
    .AvUnknow = NullByte("0", 1)
    
    If chkAvActWeek.Value = 1 Then
        .AvActWeek = HexToString("01")
    Else
        .AvActWeek = HexToString("00")
    End If
    
    .AvActWeek0 = NullByte("0", 3)
        
    .AvPriceWeekG = txtToSave(txtAvPriceWeekG.Text)
    .AvPriceWeekC = txtToSave(txtAvPriceWeekC.Text)
    
    .AvActN1 = NullByte("0", 1)
    .AvActN10 = NullByte("0", 3)
    .AvPriceN1G = NullByte("0", 4)
    .AvPriceN1C = NullByte("0", 4)
    
    If chkAvActMonth.Value = 1 Then
        .AvActMonth = HexToString("01")
    Else
        .AvActMonth = HexToString("00")
    End If

    .AvActMonth0 = NullByte("0", 3)
    .AvPriceMonthG = txtToSave(txtAvPriceMonthG.Text)
    .AvPriceMonthC = txtToSave(txtAvPriceMonthC.Text)
    
    .AvActN2 = NullByte("0", 1)
    .AvActN20 = NullByte("0", 3)
    .AvPriceN2G = NullByte("0", 4)
    .AvPriceN2C = NullByte("0", 4)
    
    If chkAvActIlimit.Value = 1 Then
        .AvActIlimit = HexToString("01")
    Else
        .AvActIlimit = HexToString("00")
    End If
    
    .AvActIlimit0 = NullByte("0", 3)
    .AvPriceIlimitG = txtToSave(txtAvPriceIlimitG.Text)
    .AvPriceIlimitC = txtToSave(txtAvPriceIlimitC.Text)
    
    If chkAvActGold.Value = 1 Then
        .AvActGold = HexToString("01")
    Else
        .AvActGold = HexToString("00")
    End If
    
    If chkAvActCash.Value = 1 Then
        .AvActCash = HexToString("01")
    Else
        .AvActCash = HexToString("00")
    End If
    
    .AvGoldCash0 = NullByte("0", 2)
    
    .AvSDelay = HexToString(Hex(StatsSave(txtAvSDelay.Text)))
    .AvSDelay0 = NullByte("0", 3)
    .AvBunge = HexToString(Hex(StatsSave(txtAvBunge.Text)))
    .AvBunge0 = NullByte("0", 3)
    .AvAttack = HexToString(Hex(StatsSave(txtAvAttack.Text)))
    .AvAttack0 = NullByte("0", 3)
    .AvDefense = HexToString(Hex(StatsSave(txtAvDefense.Text)))
    .AvDefense0 = NullByte("0", 3)
    .AvHealt = HexToString(Hex(StatsSave(txtAvHealt.Text)))
    .AvHealt0 = NullByte("0", 3)
    .AvIDelay = HexToString(Hex(StatsSave(txtAvIDelay.Text)))
    .AvIDelay0 = NullByte("0", 3)
    .AvShield = HexToString(Hex(StatsSave(txtAvShield.Text)))
    .AvShield0 = NullByte("0", 3)
    .AvPopularity = HexToString(Hex(StatsSave(txtAvPopularity.Text)))
    .AvPopularity0 = NullByte("0", 3)
    
    .AvDescription = txtAvDescription.Text + NullByte("0", Len(.AvDescription) - Len(txtAvDescription))
        
    .AvSepara = NullByte("0", 484)
 
End With

'
Escreve dados em um arquivo e posição
Put 
#FileFree, (RegActual - 1) * Len(Datos) + 5, Datos
End Sub

Private Sub Label8_Click()

End Sub

Private Sub mnuOpen_Click()

    
Cargar
    
End Sub


Private Sub mnuExit_Click()
    
End
End Sub
Private Sub Cargar()
    
dlgAbrir.DialogTitle "Abrir"
    
dlgAbrir.Filter "Avatars Dat (*.dat)|*.dat"
    
    
dlgAbrir.ShowOpen
    
    txtFileName
.Text dlgAbrir.FileName
    txtFileTitle
.Text dlgAbrir.FileTitle
    
    
If Not txtFileName.Text "" And Not txtFileTitle.Text "" Then
    
        FileFree 
FreeFile
        Open dlgAbrir
.FileName For Binary As FileFree Len Len(Datos)
        
RegActual 1
        
' Armazenar a posição do último registro
        RegUltimo = LOF(FileFree) / Len(Datos)
        txtContador = RegUltimo
        If RegUltimo = 0 Then
            RegUltimo = 1
        End If
        
        VisualizarDatos
    End If
    
End Sub

Private Sub VisualizarDatos()
    Get #FileFree, (RegActual - 1) * Len(Datos) + 5, Datos
    
'    
With Datos0
        
'txtContador = Val("&H" + StringToHex(Mid$(.AvContador, 4, 1)) + StringToHex(Mid$(.AvContador, 3, 1)) + StringToHex(Mid$(.AvContador, 2, 1)) + StringToHex(Mid$(.AvContador, 1, 1)))
        '
Datos = .AvPart2
    
'End With
    
    With Datos
        txtAvNoMenu = Val("&H" + StringToHex(Mid$(.AvNoMenu, 4, 1)) + StringToHex(Mid$(.AvNoMenu, 3, 1)) + StringToHex(Mid$(.AvNoMenu, 2, 1)) + StringToHex(Mid$(.AvNoMenu, 1, 1)) + "&")
        txtAvNoImg = Val("&H" + StringToHex(Mid$(.AvNoImg, 4, 1)) + StringToHex(Mid$(.AvNoImg, 3, 1)) + StringToHex(Mid$(.AvNoImg, 2, 1)) + StringToHex(Mid$(.AvNoImg, 1, 1)) + "&")
        txtAvNew = StringToHex(.AvNew)
        txtAvName = Trim(.AvName)
        txtAvVisible = StringToHex(.AvVisible)
        
        txtAvActWeek = Val("&H" + StringToHex(Mid$(.AvActWeek, 1, 1)))
        txtAvPriceWeekG = Val("&H" + StringToHex(Mid$(.AvPriceWeekG, 4, 1)) + StringToHex(Mid$(.AvPriceWeekG, 3, 1)) + StringToHex(Mid$(.AvPriceWeekG, 2, 1)) + StringToHex(Mid$(.AvPriceWeekG, 1, 1)) + "&")
        txtAvPriceWeekC = Val("&H" + StringToHex(Mid$(.AvPriceWeekC, 4, 1)) + StringToHex(Mid$(.AvPriceWeekC, 3, 1)) + StringToHex(Mid$(.AvPriceWeekC, 2, 1)) + StringToHex(Mid$(.AvPriceWeekC, 1, 1)) + "&")
        
        txtAvActMonth = Val("&H" + StringToHex(Mid$(.AvActMonth, 1, 1)))
        txtAvPriceMonthG = Val("&H" + StringToHex(Mid$(.AvPriceMonthG, 4, 1)) + StringToHex(Mid$(.AvPriceMonthG, 3, 1)) + StringToHex(Mid$(.AvPriceMonthG, 2, 1)) + StringToHex(Mid$(.AvPriceMonthG, 1, 1)) + "&")
        txtAvPriceMonthC = Val("&H" + StringToHex(Mid$(.AvPriceMonthC, 4, 1)) + StringToHex(Mid$(.AvPriceMonthC, 3, 1)) + StringToHex(Mid$(.AvPriceMonthC, 2, 1)) + StringToHex(Mid$(.AvPriceMonthC, 1, 1)) + "&")
        
        txtAvActIlimit = Val("&H" + StringToHex(Mid$(.AvActIlimit, 1, 1)))
        txtAvPriceIlimitG = Val("&H" + StringToHex(Mid$(.AvPriceIlimitG, 4, 1)) + StringToHex(Mid$(.AvPriceIlimitG, 3, 1)) + StringToHex(Mid$(.AvPriceIlimitG, 2, 1)) + StringToHex(Mid$(.AvPriceIlimitG, 1, 1)) + "&")
        txtAvPriceIlimitC = Val("&H" + StringToHex(Mid$(.AvPriceIlimitC, 4, 1)) + StringToHex(Mid$(.AvPriceIlimitC, 3, 1)) + StringToHex(Mid$(.AvPriceIlimitC, 2, 1)) + StringToHex(Mid$(.AvPriceIlimitC, 1, 1)) + "&")
        
        txtAvActGold = Val("&H" + StringToHex(Mid$(.AvActGold, 1, 1)))
        txtAvActCash = Val("&H" + StringToHex(Mid$(.AvActCash, 1, 1)))
        
        txtAvSDelay = StatsView(Val("&H" + StringToHex(Mid$(.AvSDelay, 1, 1))))
        txtAvBunge = StatsView(Val("&H" + StringToHex(Mid$(.AvBunge, 1, 1))))
        txtAvAttack = StatsView(Val("&H" + StringToHex(Mid$(.AvAttack, 1, 1))))
        txtAvDefense = StatsView(Val("&H" + StringToHex(Mid$(.AvDefense, 1, 1))))
        txtAvHealt = StatsView(Val("&H" + StringToHex(Mid$(.AvHealt, 1, 1))))
        txtAvIDelay = StatsView(Val("&H" + StringToHex(Mid$(.AvIDelay, 1, 1))))
        txtAvShield = StatsView(Val("&H" + StringToHex(Mid$(.AvShield, 1, 1))))
        txtAvPopularity = StatsView(Val("&H" + StringToHex(Mid$(.AvPopularity, 1, 1))))
        
        txtAvDescription = Trim(.AvDescription)
        
    End With
    
    '
MsgBox (txtAvNew)
    If 
Val("&H" txtAvNew.Text) = 1 Then
        chkAvNew
.Value 1
    
Else
        
chkAvNew.Value 0
    End 
If
    
    If 
Val("&H" txtAvVisible) = 1 Then
        chkAvVisible
.Value 1
    
Else
        
chkAvVisible.Value 0
    End 
If
    
    If 
Val("&H" txtAvActWeek) = 1 Then
        chkAvActWeek
.Value 1
    
Else
        
chkAvActWeek.Value 0
    End 
If
    
    If 
Val("&H" txtAvActMonth) = 1 Then
        chkAvActMonth
.Value 1
    
Else
        
chkAvActMonth.Value 0
    End 
If
    
    If 
Val("&H" txtAvActIlimit) = 1 Then
        chkAvActIlimit
.Value 1
    
Else
        
chkAvActIlimit.Value 0
    End 
If
    
    If 
Val("&H" txtAvActGold) = 1 Then
        chkAvActGold
.Value 1
    
Else
        
chkAvActGold.Value 0
    End 
If
    
    If 
Val("&H" txtAvActCash) = 1 Then
        chkAvActCash
.Value 1
    
Else
        
chkAvActCash.Value 0
    End 
If
        
    
Combo1 Combo1.List(0)
    
mnuSave.Enabled True
    
End Sub

Private Sub cmdSiguiente_click()

If 
RegActual RegUltimo Then
    MsgBox 
" Ultimo registro "vbInformation
Else
'Aumenta a posição
RegActual = RegActual + 1
'
Coloque os dados na caixa de texto próximo registro
VisualizarDatos
End 
If

End Sub

Private Sub cmdBuscar_click()

Dim Encontrado As BooleanPosReg As Longtmp As StructAvatars

If txtBuscar "" Then txtAvName.SetFocus: Exit Sub

Encontrado 
False

'Vamos do começo ao fim em busca do registro para encontrar

For PosReg = 1 To RegUltimo

'
Nós lemos o registro
Get 
#FileFree, (PosReg - 1) * Len(tmp) + 5, tmp

'Se os dados é o mesmo ciclo que
txtBuscar2 = BuscarPor(tmp)

If UCase(txtBuscar) = UCase(txtBuscar2) Then
    Encontrado = True
    Exit For
End If

Next

If Encontrado Then
    
    RegActual = PosReg
    '
Coloque os dados do texto
    VisualizarDatos

Else
    
MsgBox "Nome: " txtBuscar " Nenhum registro encontrado"
End If

End Sub

Private Function BuscarPor(As StructAvatars)

Select Case Combo1.ListIndex

Case 0BuscarPor Trim(t.AvName)
Case 
1BuscarPor Val("&H" StringToHex(Mid$(t.AvNoMenu41)) + StringToHex(Mid$(t.AvNoMenu31)) + StringToHex(Mid$(t.AvNoMenu21)) + StringToHex(Mid$(t.AvNoMenu11)) + "&")

End Select

End 
Function

Private 
Sub CmdNuevo_click()

'Limpeza estrutura de dados para adicionar um novo registro
With Datos
    .AvNoMenu = ""
    
    .AvNoImg = ""
    
    .AvNew = ""
    .AvNew0 = ""
    
    .AvName = ""
    
    .AvVisible0 = ""
    .AvVisible = ""
    
    .AvUnknow = ""
    
    .AvActWeek = ""
    .AvActWeek0 = ""
    .AvPriceWeekG = ""
    .AvPriceWeekC = ""
    
    .AvActN1 = ""
    .AvActN10 = ""
    .AvPriceN1G = ""
    .AvPriceN1C = ""
    
    .AvActMonth = ""
    .AvActMonth0 = ""
    .AvPriceMonthG = ""
    .AvPriceMonthC = ""
    
    .AvActN2 = ""
    .AvActN20 = ""
    .AvPriceN2G = ""
    .AvPriceN2C = ""
    
    .AvActIlimit = ""
    .AvActIlimit0 = ""
    .AvPriceIlimitG = ""
    .AvPriceIlimitC = ""
    
    .AvActGold = ""
    .AvActCash = ""
    .AvGoldCash0 = ""
    
    .AvSDelay = ""
    .AvSDelay0 = ""
    .AvBunge = ""
    .AvBunge0 = ""
    .AvAttack = ""
    .AvAttack0 = ""
    .AvDefense = ""
    .AvDefense0 = ""
    .AvHealt = ""
    .AvHealt0 = ""
    .AvIDelay = ""
    .AvIDelay0 = ""
    .AvShield = ""
    .AvShield0 = ""
    .AvPopularity = ""
    .AvPopularity0 = ""
    
    .AvDescription = ""
        
    .AvSepara = ""
 
End With

Grava dados no novo registro até que você pressione o botão _
Salvar que registra os dados reais
'MsgBox (RegUltimo & "----" & Len(Datos))
Put #FileFree, (RegUltimo) * Len(Datos) + 5, Datos

RegActual = RegUltimo

VisualizarDatos
End Sub


Private Function HexToString(ByVal HexToStr As String) As String
Dim strTemp   As String
Dim strReturn As String
Dim I         As Long
    For I = 1 To Len(HexToStr) Step 3
        strTemp = Chr$(Val("&H" & Mid$(HexToStr, I, 2)))
        strReturn = strReturn & strTemp
    Next I
    HexToString = strReturn
End Function

Private Function StringToHex(ByVal StrToHex As String) As String
Dim strTemp   As String
Dim strReturn As String
Dim I         As Long
    For I = 1 To Len(StrToHex)
        strTemp = Hex$(Asc(Mid$(StrToHex, I, 1)))
        If Len(strTemp) = 1 Then strTemp = "0" & strTemp
        strReturn = strReturn & strTemp
    Next I
    StringToHex = strReturn
End Function

Private Function NullByte(ByVal StrToNull As String, ByVal Contador As Integer) As String
Dim strReturn As String
Dim I As Long

For I = 1 To Contador
    strReturn = strReturn + HexToString("0")
Next I

    NullByte = strReturn

End Function

Private Function NullHex(ByVal StrToHex As String, ByVal Contador As Integer) As String
Dim strReturn As String
Dim I As Long
strReturn = StrToHex
For I = 1 To Contador
    strReturn = "0" + strReturn
Next I

    NullHex = strReturn

End Function

Private Function StatsView(ByVal StrToStat As String) As String
    If StrToStat > 50 Then
        StatsView = StrToStat - 255
    Else
        StatsView = StrToStat
    End If
End Function

Private Function StatsSave(ByVal StrToStat As String) As String
    If StrToStat < 0 Then
        StatsSave = StrToStat + 255
    Else
        StatsSave = StrToStat
    End If
End Function

Private Function txtToSave(ByVal StrToHex As String) As String
Dim t As StructAvatars

    StrToHex = NullHex(Hex(StrToHex), Len(t.AvNoImg) * 2 - Len(Hex(StrToHex)))
    StrToHex = HexToString(Mid$(StrToHex, 7, 2)) + HexToString(Mid$(StrToHex, 5, 2)) + HexToString(Mid$(StrToHex, 3, 2)) + HexToString(Mid$(StrToHex, 1, 2))
    txtToSave = StrToHex + NullByte("0", Len(t.AvNoImg) - Len(StrToHex))
    
End Function 
Responder Con Cita
  #2  
Antiguo 08-10-2018
Avatar de Casimiro Notevi
Casimiro Notevi Casimiro Notevi is offline
Moderador
 
Registrado: sep 2004
Ubicación: En algún lugar.
Posts: 32.021
Poder: 10
Casimiro Notevi Tiene un aura espectacularCasimiro Notevi Tiene un aura espectacular
Claro, ¿cuál es el problema?
Responder Con Cita
  #3  
Antiguo 08-10-2018
DarkSton DarkSton is offline
Miembro
 
Registrado: jun 2017
Posts: 64
Poder: 7
DarkSton Va por buen camino
hola

el programa es un editor de archivos dat lo cual contiene datos de nombre, presio ,descripcion
Responder Con Cita
  #4  
Antiguo 08-10-2018
Avatar de movorack
[movorack] movorack is offline
Miguel A. Valero
 
Registrado: feb 2007
Ubicación: Bogotá - Colombia
Posts: 1.346
Poder: 20
movorack Va camino a la famamovorack Va camino a la fama
Listo. aquí te estoy pasando el fuente.

__________________
Buena caza y buen remar... http://mivaler.blogspot.com
Responder Con Cita
  #5  
Antiguo 09-10-2018
Avatar de Neftali [Germán.Estévez]
Neftali [Germán.Estévez] Neftali [Germán.Estévez] is offline
[becario]
 
Registrado: jul 2004
Ubicación: Barcelona - España
Posts: 18.233
Poder: 10
Neftali [Germán.Estévez] Es un diamante en brutoNeftali [Germán.Estévez] Es un diamante en brutoNeftali [Germán.Estévez] Es un diamante en bruto
Creo que lo que te "intentan" explicar aquí los compañeros, es algo así como, que para preguntar por una dirección, necesitas dar "una dirección concreta" y no pedir que te expliquen "todo el mapa de la ciudad".


Deberías intentar concretar y decir dónde tienes problemas, pero no pasar un proyecto completo y pedir que "te lo traduzcan".
Los foros son un lugar donde se ayuda a los demás, pero no un lugar para que te hagan el trabajo gratis. Hay una sutil difderencia.

Un saludo.
__________________
Germán Estévez => Web/Blog
Guía de estilo, Guía alternativa
Utiliza TAG's en tus mensajes.
Contactar con el Clubdelphi

P.D: Más tiempo dedicado a la pregunta=Mejores respuestas.
Responder Con Cita
Respuesta


Herramientas Buscar en Tema
Buscar en Tema:

Búsqueda Avanzada
Desplegado

Normas de Publicación
no Puedes crear nuevos temas
no Puedes responder a temas
no Puedes adjuntar archivos
no Puedes editar tus mensajes

El código vB está habilitado
Las caritas están habilitado
Código [IMG] está habilitado
Código HTML está deshabilitado
Saltar a Foro

Temas Similares
Tema Autor Foro Respuestas Último mensaje
Como puedo pasar este codigo a delphi el codigo de la imagen es codigo python Javier13 Varios 9 16-11-2017 16:41:33
Ayuda a pasar este código a firemonkey. elmago00 FireMonkey 55 08-01-2015 16:25:18
Ayuda a pasar codigo delphi7 a XE3 elmago00 Varios 2 25-11-2014 19:27:05
Pasar este mini-codigo a C++Builder aguml C++ Builder 10 24-06-2014 22:09:12
Que opinan de este mensaje de Delphi7? locotenentul Varios 9 08-07-2008 00:08:30


La franja horaria es GMT +2. Ahora son las 22:30:18.


Powered by vBulletin® Version 3.6.8
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Traducción al castellano por el equipo de moderadores del Club Delphi
Copyright 1996-2007 Club Delphi