Imprimir página | Cerrar ventana

Instalar, leer fuente de windows(codigo barras)

Impreso de: Foro de Access y VBA
Categoría: Access y VBA
Nombre del foro: Access y VBA
Descripción del foro: Foro de programacion en Access (Con código y sin código)
URL: http://www.mvp-access.com/foro/forum_posts.asp?TID=84646
Fecha de impresión: 11/Noviembre/2019 a las 21:34


Tema: Instalar, leer fuente de windows(codigo barras)
Publicado por: rokoko
Asunto: Instalar, leer fuente de windows(codigo barras)
Fecha de publicación: 15/Agosto/2019 a las 17:45
Hola

Hay alguna forma desde vba que access lea la fuente de codigo de barras sin tenerla instalada??
El objetivo es que lo lea desde una carpeta que yo designe.

Tambien he probado desde vba a copiar la fuente a la carpeta windows\Fonts  pero no lo hace e instala.

Saludos



Respuestas:
Publicado por: rokoko
Fecha de publicación: 15/Agosto/2019 a las 18:02
Algo he conseguido buscando en google esto  AddFontResource Lib "gdi32"

https://www.lawebdelprogramador.com/foros/Visual-Basic/8535-Como-poner-fuentes-de-letra-en-Vb.html" rel="nofollow - https://www.lawebdelprogramador.com/foros/Visual-Basic/8535-Como-poner-fuentes-de-letra-en-Vb.html

http://www.pablin.com.ar/computer/programa/vb/agregttf.htm" rel="nofollow - http://www.pablin.com.ar/computer/programa/vb/agregttf.htm


http://www.freevbcode.com/ShowCode.asp?ID=1945" rel="nofollow - http://www.freevbcode.com/ShowCode.asp?ID=1945


Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long

Instala la fuente

Dim result As Long

result = AddFontResource("C:\Users\Norco\Desktop\BD16 Biblioteca\IDAutomationHC39M.ttf")


Desinstala la fuente

Dim result As Long

result = RemoveFontResource("C:\Users\Norco\Desktop\BD16 Biblioteca\IDAutomationHC39M.ttf")


Pero lo ideal seria que lo leiese desde la carpeta que yo quiera, ademas de la forma anterior si no esres administrador dudo mucho que lo instale.

Lo curioso de usar el sistema expuesto es que en la carpeta de las fuentes no sale, pero esta instalado.


Publicado por: rokoko
Fecha de publicación: 25/Agosto/2019 a las 15:13
Algo he conseguido.
Si ulilizo una fuente instalada no hay problema.

He encontrado este codigo que funciona, siempre que no esten los asteriscos en el codigo de barras. Si pongo asteriscos me lo saca asi con este simbolo (   por ejemplo el codigo 000002 sale   (000002(  no tengo ni idea por que.... El codigo del asterisco por lo que he visto es el correcto, lo remarco en el codigo. A alguno se os ocurre el porque???


Public Function FC_barcode3of9(ByVal strWord As String, _
                               ByVal strObj As Object)


Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim pos As Integer
Dim Barcode As String
Dim Cur As String
Dim CurVal As Integer
Dim BC(0 To 43) As String

    BC(0) = "000110100" '0
    BC(1) = "100100001" '1
    BC(2) = "001100001" '2
    BC(3) = "101100000" '3
    BC(4) = "000110001" '4
    BC(5) = "100110000" '5
    BC(6) = "001110000" '6
    BC(7) = "000100101" '7
    BC(8) = "100100100" '8
    BC(9) = "001100100" '9
    BC(10) = "100001001" 'A
    BC(11) = "001001001" 'B
    BC(12) = "101001000" 'C
    BC(13) = "000011001" 'D
    BC(14) = "100011000" 'E
    BC(15) = "001011000" 'F
    BC(16) = "000001101"
    BC(17) = "100001100"
    BC(18) = "001001100"
    BC(19) = "000011100"
    BC(20) = "100000011"
    BC(21) = "001000011"
    BC(22) = "101000010"
    BC(23) = "000010011"
    BC(24) = "100010010"
    BC(25) = "001010010"
    BC(26) = "000000111"
    BC(27) = "100000110"
    BC(28) = "001000110"
    BC(29) = "000010110"
    BC(30) = "110000001"
    BC(31) = "011000001"
    BC(32) = "111000000" 'W
    BC(33) = "010010001" 'X
    BC(34) = "110010000" 'Y
    BC(35) = "011010000" 'Z
    BC(36) = "010000101" '-
    BC(37) = "110000100" '.
    BC(38) = "011000100" '<spc>
    BC(39) = "010101000" '$
    BC(40) = "010100010" '/
    BC(41) = "010001010" '+
    BC(42) = "000101010" '&#37;
    BC(43) = "010010100"   '*  (used for start/stop character only)
    
strObj.Cls
pos = 20 '10
Barcode = UCase(strWord)

'Add Start & Stop characters?
'If Check1.value Then Barcode = "*" & Barcode & "*"

'If Check1.Value Then
Barcode = "*" & Barcode & "*"


'Generate Barcode
For x = 1 To Len(Barcode)
    Cur = Mid$(Barcode, x, 1)
    Select Case Cur
    Case "0" To "9"
        CurVal = Val(Cur)
    Case "A" To "Z"
        CurVal = Asc(Cur) - 55
    Case "-"
        CurVal = 36
    Case "."
        CurVal = 37
    Case " "
        CurVal = 38
    Case "$"
        CurVal = 39
    Case "/"
        CurVal = 40
    Case "+"
        CurVal = 41
    Case "%"
        CurVal = 42
    Case "*"
        CurVal = 43
    Case Else 'oops!
        strObj.Cls
        strObj.Print Cur & " is Invalid"
        Exit Function
    End Select
    
    For y = 1 To 9
        If y / 2 = Int(y / 2) Then
            'SPACE
            pos = pos + 1 + (3 * Val(Mid$(BC(CurVal), y, 1)))
        Else
            'BAR
            For z = 1 To 1 + (3 * Val(Mid$(BC(CurVal), y, 1)))
                strObj.Line (pos, 1)-(pos, 50) ''strObj.Line (pos, 1)-(pos, 50)
                pos = pos + 1
            Next z
        End If
    Next y
    pos = pos + 1 'make inter-character gap (ie: 1 narrow space)
Next x

'Add Label?
'If Check2.value = True Then 'false
'    strObj.CurrentX = Len(Barcode) * 7 'kinda center
'    strObj.Print Barcode
'End If




End Function 'BC





Publicado por: MexMan70
Fecha de publicación: 27/Agosto/2019 a las 17:00
Hola Rokoko, no he entendido tu pregunta. Acaso te refieres a que Acces verifique si esta instalada una tipografía (fuenre) y en caso de no existir que la instalé?
O acaso simplemente deseas leer los "palitos" ?

Saludos !

-------------
OneDrive: http://sdrv.ms/Vk6eJd


Publicado por: rokoko
Fecha de publicación: 27/Agosto/2019 a las 23:01
Lo que quiero es tener codigo de barras pero que no lo coja de una fuente(para no tener obligación de tenerla instalada). Que sea mediante codigo vba.

Saludos


Publicado por: rokoko
Fecha de publicación: 02/Octubre/2019 a las 13:16
Se puede cerrar. Lo he solucionado como el tercer mensaje quitando los asteriscos.



Imprimir página | Cerrar ventana