Crear txt oculto

Dudas sobre Tablas, Consultas, Formularios, Informes...
Avatar de Usuario
bryger
Nivel 4
Mensajes: 121
Registrado: Mié Jul 06, 2016 12:24 pm

Crear txt oculto

Mensajepor bryger » Vie Nov 09, 2018 2:08 am

Buenas tengo una bd que me crea un txt segun donde se encuentre la bd si esta en el escritorio al aperturar me crea un txt segun el nombre que le di en el codigo lo que quiero saber es como guardarla en windows system32 y que este txt este oculto he probado varias formas al cambiar la ruta pero no me da
este es el modulo que me codifica el serial

Código: Seleccionar todo

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" ( _
                         ByVal lpBuffer As String, _
                         ByVal nSize As Long) As Long
                         
Private Function ConvToHex(x As Integer) As String
    If x > 9 Then
        ConvToHex = Chr(x + 55)
    Else
        ConvToHex = CStr(x)
    End If
End Function
 
' función que codifica el dato
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 Function Encriptar(DataValue As Variant) As Variant
     
    Dim x As Long
    Dim Temp As String
    Dim TempNum As Integer
    Dim TempChar As String
    Dim TempChar2 As String
     
    For x = 1 To Len(DataValue)
        TempChar2 = Mid(DataValue, x, 1)
        TempNum = Int(Asc(TempChar2) / 16)
         
        If ((TempNum * 16) < Asc(TempChar2)) Then
                 
            TempChar = ConvToHex(Asc(TempChar2) - (TempNum * 16))
            Temp = Temp & ConvToHex(TempNum) & TempChar
        Else
            Temp = Temp & ConvToHex(TempNum) & "0"
         
        End If
    Next x
     
     
    Encriptar = Temp
End Function
Private Function ConvToInt(x As String) As Integer
     
    Dim x1 As String
    Dim x2 As String
    Dim Temp As Integer
     
    x1 = Mid(x, 1, 1)
    x2 = Mid(x, 2, 1)
     
    If IsNumeric(x1) Then
        Temp = 16 * Int(x1)
    Else
        Temp = (Asc(x1) - 55) * 16
    End If
     
    If IsNumeric(x2) Then
        Temp = Temp + Int(x2)
    Else
        Temp = Temp + (Asc(x2) - 55)
    End If
     
    ' retorno
    ConvToInt = Temp
     
End Function
 
' función que decodifica el dato
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Desencriptar(DataValue As Variant) As Variant
     
    Dim x As Long
    Dim Temp As String
    Dim HexByte As String
     
    For x = 1 To Len(DataValue) Step 2
         
        HexByte = Mid(DataValue, x, 2)
        Temp = Temp & Chr(ConvToInt(HexByte))
         
    Next x
    ' retorno
    Desencriptar = Temp
     
End Function

Function LeeLineaTxt(strRuta As String, StrPath As String, Linea As Long) As Variant
On Error Resume Next
'Declaro las variable
Dim fso                                                     As New FileSystemObject
Dim Archivo                                                 As TextStream
Dim I                                                       As Integer


                    'Creo un nuevo Objeto
                    Set fso = CreateObject("Scripting.FileSystemObject")
       
        'Creo un marcador de posicion variable
         Set Archivo = fso.OpenTextFile(strRuta & "\" & StrPath, 1)

               'Recorro el txt y me detengo en la linea especificada
                For I = 1 To Linea
 
      'Leo la linea especificada a la cargo a la memoria del objeto
       Archivo.Skipline

Next 'Continuo el recorrido

        'Al cerrar el bucle le escribo a la Funcion lo que leyo Skipline
         LeeLineaTxt = Archivo.ReadLine()
         

    'Cierro el Objeto
    Archivo.Close

'Desvinculo los Objetos
Set fso = Nothing
Set Archivo = Nothing

err.Clear
End Function
Function Get_Numero_Serie(ByVal s_Drive As String) As Long
          Dim o_Fso As Scripting.FileSystemObject
          Dim o_Drive As Drive
          Set o_Fso = New Scripting.FileSystemObject
          If s_Drive <> "" Then
              Set o_Drive = o_Fso.GetDrive(s_Drive)
          End If
          With o_Drive
              If .IsReady Then
                  Get_Numero_Serie = Not .SerialNumber
              Else
              End If
          End With
          Set o_Drive = Nothing
          Set o_Fso = Nothing
End Function

Sub InicioRegistro(frm As Form)
If JJJT_ExisteDir(CurrentProject.Path & "\" & "XpsDocumentTargetPrint.log") Then
On Error Resume Next
If Encriptar(Get_Numero_Serie("C:\")) <> Nz(DLookup("MyDisk", "MSysNavPaneObjectIDs", "Name = 'MSysObjects'"), vbNullString) Then
Dim DiaHoy, DiaReg As Date
Dim LeoDia, LeoMes, LeoAño As Long
DiaHoy = Format(Date, "dd/mm/yyyy")
LeoDia = left(LeeLineaTxt(CurrentProject.Path, "XpsDocumentTargetPrint.log", 0), 2)
LeoMes = Mid(LeeLineaTxt(CurrentProject.Path, "XpsDocumentTargetPrint.log", 0), 4, 2)
LeoAño = right(LeeLineaTxt(CurrentProject.Path, "XpsDocumentTargetPrint.log", 0), 4)
DiaReg = Format(LeoDia & "/" & LeoMes & "/" & LeoAño, "dd/mm/yyyy")
Select Case DiaReg + 30 < DiaHoy
Case True
MsgBox "ya han transcurrido 30 dias de evaluacion", vbInformation
DoCmd.Close acForm, frm.Name
Cancel = True
Exit Sub
End Select
End If
Else
MsgBox "Debe crear el archivo txt de fecha y serial disco duro", vbInformation
DoCmd.Close acForm, frm.Name
Cancel = True
Exit Sub
End If
err.Clear
End Sub

Function JJJT_ExisteDir(ByVal Ruta As String) As Boolean
    On Error Resume Next
    JJJT_ExisteDir = (GetAttr(Ruta) And vbNormal) = vbNormal
    err.Clear
End Function

Function SystemFolder() As String
Dim Buffer As String * 256
Dim Tam As Long
      ' Muestra el path del directorio de sistema
        Tam = GetSystemDirectory(Buffer, Len(Buffer))
        SystemFolder = left$(Buffer, Tam) & "\"
End Function


y este es lo que utilizo para llamarlo desde el boton

Código: Seleccionar todo

Private Sub Usuario_Click()
If JJJT_ExisteDir(DiR & "\" & "XpsDocumentTargetPrintt.log") = False Then EscribeTxt Encriptar(Get_Numero_Serie("C:\")), "XpsDocumentTargetPrintt.log", DiR
If JJJT_ExisteDir(DiR & "\" & "XpsDocumentTargetPrintt.log") Then Else
If JJJT_ExisteDir(DiR & "\" & "XpsDocumentTargetPrint.log") = False Then EscribeTxt Format(Date, "dd/mm/yyyy"), "XpsDocumentTargetPrint.log", DiR
If JJJT_ExisteDir(DiR & "\" & "XpsDocumentTargetPrint.log") Then Else
End Sub
Private Sub EscribeTxt(Datos As String, Archivo As String, LaRuta As String)
On Error Resume Next
Dim NumeroInt                                               As Long
Dim Escribe                                                 As String
    LaRuta = LaRuta & "C:\Archivo.TXT" & Archivo
      NumeroInt = FreeFile
          Open LaRuta For Output As #NumeroInt
             Escribe = Datos
        Print #NumeroInt, Escribe
  Close #NumeroInt
  err.Clear
End Sub

Private Function DiR()
DiR = CurrentProject.Path
End Function

pitxiku
VIP
Reto01
Mensajes: 199
Registrado: Sab Sep 30, 2017 6:23 pm

Re: Crear txt oculto

Mensajepor pitxiku » Sab Nov 10, 2018 11:46 am



Volver a “Objetos Access”

¿Quién está conectado?

Usuarios navegando por este Foro: No hay usuarios registrados visitando el Foro y 1 invitado