Ir para o conteúdo

Publicidade

 Estatísticas do Fórum

  • 1 Usuários ativos

    0 membro(s), 1 visitante(s) e 0 membros anônimo(s)

Foto:

Funções, rotinas e dicas

  • Por favor, faça o login para responder
23 respostas neste tópico

#1 slype

slype
  • Membros
  • 99 posts

Postado 15 novembro 2005 - 09:48

Iai Amigos, blzzz...

Seguinte, vamos colocar aki nesse tópico algumas FUNÇÕES, ROTINAS, DICAS etc... (Algumas coisas Úteis e/ou Legais de VB)


Pra começar eu ja vo colocando uma rotina que uso muito em meus Projetos:


AUTO COMPLETE EM COMBOBOX:

1- Crie uma nova Classe de Módulo e renomeie como: clsAutoComplete

2- Na Classe de Módulo cole a rotina:


Private WithEvents pCombo As ComboBox
Private IsDelOrBack As Boolean

Public Sub Bind(Cmb As ComboBox)
Set pCombo = Cmb
End Sub

Private Sub Class_Terminate()
Set pCombo = Nothing
End Sub

Private Sub pCombo_Change()
On Error Resume Next
Dim OldLen As Integer
Dim i As Integer

If Not pCombo.Text = "" And Not IsDelOrBack Then
	OldLen = Len(pCombo.Text)
	For i = 0 To pCombo.ListCount - 1
		If InStr(1, Mid$(UCase(pCombo.List(i)), 1, OldLen), UCase(pCombo.Text)) Then
			pCombo.Text = pCombo.List(i)
			If pCombo.SelText = "" Then
				pCombo.SelStart = OldLen
			Else
				pCombo.SelStart = InStr(pCombo.Text, pCombo.SelText)
			End If
			pCombo.SelLength = Len(pCombo.Text)
			Exit For
		End If
	Next
End If
End Sub

Private Sub pCombo_KeyDown(KeyCode As Integer, Shift As Integer)
IsDelOrBack = (KeyCode = vbKeyBack Or KeyCode = vbKeyDelete)
End Sub

3- No Form que for usar o Auto Complete declare a Classe de Módulo:

Dim Complete As New clsAutoComplete

4- E por fim, chame a Rotina no seu ComboBox:

Complete.Bind cboNome
* Onde cboNome é o nome do seu ComboBox.

Obs: Use o comando acima para chamar a rotina depois de ter Enchido ele ou no LOAD do Form.

É isso ae, Postem as suas agora.... até
  • 0

#2 slype

slype
  • Membros
  • 99 posts

Postado 15 novembro 2005 - 16:29

Varias Opções para FORMs muito uteis:


CLIQUE AQUI
  • 0

#3 cassitos

cassitos

    vamu q vamu! ^_^

  • Membros
  • 998 posts

Postado 17 novembro 2005 - 23:00

Eis outro link com dicas:
http://www.silicio.c...s/abertura.html
  • 0

#4 slype

slype
  • Membros
  • 99 posts

Postado 20 novembro 2005 - 10:50

Pode ser que muitos saibam dessas discas de uso, mais vou cita-las, são bem uteis:

1- Quando estiver digitando um comando, utilize (CTRL + ESPAÇO), o VB te mostra todos os comando que você pode estar utilizando nessa linha.

2- Quando desejar procurar uma propriedade de um Objeto, ao invez ficar rolando a barra com o mouse, aperte: CHIFT + CTRL + (a primeira letra da propriedade.
Exemplo, você quer a propriedade "TEXT" = CHIFT + CTRL + T

3 - Ao ver uma chamada de Função, Sub ou Variavel, para ir até a definição dela basta clicar com 'botão direito' no nome > 'Definition'

4 - Para movimentar objetos de um Form com teclado: Segure CTRL e mova com as setas do teclado

5 - Para redimensionar objetos de um Form com teclado: Segure SHIFT e redimensione com as setas do teclado


...
é isso ae Galera.... Em breve posto mais, continuem postando, Até mais!
  • 1

#5 Graymalkin

Graymalkin

    Ex-moderador

  • Membros
  • 908 posts

Postado 20 novembro 2005 - 17:33

Dois tutoriais de sockets em VB:

http://www.desenvolv...=article&sid=27
http://www.desenvolv...=article&sid=26

Ah, vou pendurar esse tópico para ficar sempre visível. Boa idéia, Slype! :D

Abraços,

Graymalkin
  • 0

#6 lgustavoc

lgustavoc
  • Membros
  • 33 posts

Postado 22 novembro 2005 - 09:24

Função pra validar um e-mail


Public Function EmailOK(ByVal Email As String) As Boolean
	Dim j As Long, C As String
	If Email = "" Or Email Like "*@*" And _
	(Email Like "*.??" Or Email Like "*.???") _
	Then EmailOK = True


	If Email Like "*.???" Then
		C = Right$(Email, 4)
		If C = ".com" Or C = ".net" Or C = ".edu" _
		Or C = ".mil" Or C = ".gov" Or C = ".org" Then
	Else
		EmailOK = False
	End If
End If


For j = 1 To Len(Email)
	C = Mid$(Email, j, 1)
	If C = "@" Or C = "." Or C = "-" Or C = "_" _
	Or C >= Chr(48) And C <= Chr(57) _
	Or LCase(C) >= Chr(97) And _
	LCase(C) <= Chr(122) Then
Else
	EmailOK = False
End If
Next j
End Function

Pra chamar a função:

If EMailOK(seuemail.text)= true then
  Msgbox "E-mail válido"
Else
  Msgbox "E-mail inválido"
End If

  • 0

#7 slype

slype
  • Membros
  • 99 posts

Postado 03 dezembro 2005 - 01:23

10 dicas básicas sobre impressão com Printer.

http://www.macoratti.net/vb_print2.htm
  • 0

#8 Fabyo

Fabyo

    PHP

  • Masters
  • 5.902 posts

Postado 10 fevereiro 2006 - 13:00

Use Expressoes Regulares no VB

http://www.macoratti.net/vb_regex.htm
http://guia-er.sourceforge.net/

use ER muito melhor para validar dados tipo email, datas hora etc...
  • 0

#9 slype

slype
  • Membros
  • 99 posts

Postado 20 fevereiro 2006 - 21:06

Uma SUBzinha bastante Util que eu mesmo Criei...

Função: Escrever direto em uma MSFlexGrid

Vamos Lá....

Cole em um Módulo:
Public Sub EscreveNaGrid(Grid As MSFlexGrid, Coluna As Integer, Linha As Integer, Key As Integer, SóNumero As Boolean)
'Sub Criada por Slype - 20/02/2006
	On Error Resume Next
	If Key = 8 Then
		Grid.TextMatrix(Linha, Coluna) = Left(Grid.TextMatrix(Linha, Coluna), Len(Grid.TextMatrix(Linha, Coluna)) - 1)
	ElseIf Key = 13 Then
		Grid.Row = Grid.Row + 1
	Else
		If SóNumero = True Then
			If Not IsNumeric(Chr(Key)) And Key <> 44 Then Exit Sub
		End If
		Grid.TextMatrix(Linha, Coluna) = Grid.TextMatrix(Linha, Coluna) & Chr(Key)
	End If
End Sub

Chame a função no Evento KeyPress do seu MSFlexGrid:
Private Sub NomeDoGrid_KeyPress(KeyAscii As Integer)
	EscreveNaGrid NomeDoGrid, NomeDoGrid.Col, NomeDoGrid.Row, KeyAscii, False
End Sub

... Caso queira que seje digitado Somente Numeros Então chame assim:
Private Sub NomeDoGrid_KeyPress(KeyAscii As Integer)
	EscreveNaGrid NomeDoGrid, NomeDoGrid.Col, NomeDoGrid.Row, KeyAscii, True
End Sub

É isso ai... Espero que Seje Util á Voces!!!
falowww ate mais!!!
  • 0

#10 Fabyo

Fabyo

    PHP

  • Masters
  • 5.902 posts

Postado 27 fevereiro 2006 - 16:25

Trocar Tab por Enter

se precisar usar em varios campos coloque no keypress do formulario
e deixe o KeyPreview do formulário para True

If KeyAscii = 13 Then  SendKeys "{tab}"

para evitar um beep deixe o keyascii com valor 0 :

If KeyAscii = 13 Then
	  SendKeys "{tab}"
	  KeyAscii = 0
  End If

Permitir só numeros no campo text

coloque no KeyPress do campo text

KeyAscii = IIf(KeyAscii > 47 And KeyAscii < 58 Or KeyAscii = 8, KeyAscii, 0)

Exibir a data atual no padrao dd/mm/yyyy

só usar o format()
Format(Date, "dd/mm/yyyy")

Ultimo dia do mes:
Format(DateSerial(Year(Now), Month(Now) + 1, 0), "dd/mm/yyyy")

Deixar o campo text somente com letras maiusculas:

KeyAscii = Asc(UCase(Chr(KeyAscii)))
obs: para forçar somente minusculas use a função LCase no lugar da UCase

Função que preenche com zeros a esquerda ou direita do numero

coloque num modulo a função abaixo:
Public Function FormataZero_Esquerda(Valor As String, Casas As String)
	FormataZero_Esquerda = Left(Casas, Len(Casas) - Len(Valor)) & Valor
End Function

modo de usar :
msgbox FormataZero_Esquerda("12", "00000")

obs: para preencher com zeros a direita só inverter "Valor" na função colocando ele na frente
e pode preencher com outro caracter sem ser zero
  • 0

#11 Fabyo

Fabyo

    PHP

  • Masters
  • 5.902 posts

Postado 29 março 2006 - 09:34

Conexao Com banco de Dados MySQL usando Dll nativa "libmySQL", sem usar ODBC ou Drivers

basta Referenciar a MyVbQL.dll

e usar assim:

Dim my As MYSQL_CONNECTION
Set my = New MYSQL_CONNECTION

my.OpenConnection "localhost", "usuario", "senha", "banco"

	If my.State = MY_CONN_OPEN Then
		MsgBox "successo"
	Else
		MsgBox "Falha na conexao"
	End If

Set MyRS = my.Execute("select * from tabela")

alguns metodos:

MsgBox MyRS.RecordCount
MsgBox MyRS.FieldCount
MsgBox MyRS.Fields(0).Name

procurem essa dll no google é facil de achar mas quem nao conseguir posta ai que eu envio a dll por email

e ela tem muitos outros recursos apenas mostrei como conectar

existe tbm MyOLEDB.exe para conectar usando Provider mas nao gostei muito prefiro a MyVbQL

qualquer duvida só postar
  • 1

#12 Fabyo

Fabyo

    PHP

  • Masters
  • 5.902 posts

Postado 03 abril 2006 - 07:32

Calcular idade:

Int(DateDiff("y", CDate(data_niver), Date) / 365.25)

  • 0

#13 slype

slype
  • Membros
  • 99 posts

Postado 27 maio 2006 - 15:21

• Função para Encher um ComboBox com Dados de um Campo de uma Tabela (em ADO)

Função:
Public Function DadosCBOtabela(Cb As ComboBox, Tabela As String, Campo As String) As Boolean
	Dim Seleção as ADODB.Recordset
	StrTemp = Cb.Text
	Cb.Clear
	Set Seleção = New ADODB.Recordset
		Seleção.Open "SELECT " & Campo & " FROM " & Tabela & " ORDER BY " & Campo, BDdados, adOpenDynamic, adLockReadOnly
	If Seleção.EOF = True Then
		DadosCBOtabela = False
		Seleção.Close
		Exit Function
	End If
	Do While Not Seleção.EOF
		Cb.AddItem IIf(IsNull(Seleção(Campo)), "", Seleção(Campo))
		Seleção.MoveNext
	Loop
	DadosCBOtabela = True
	Seleção.Close
	Cb.Text = StrTemp
	StrTemp = ""
End Function
*Onde BDdados é uma connexão ADO com um Banco....

Ex de uma connexão ADO com BD Access:
Dim BDdados as ADODB.Connection
	Set BDdados = New ADODB.Connection
	BDdados.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=SENHA;" & "Data Source=C:\Dados.mdb;" & "Persist Security Info=False"
	BDdados.Open

Como chamar a Função:
DadosCBOtabela Cbo_Nome, "Clientes", "Nome"

...é isso ae galera.....Taí mais uma funçãozinha show de bola!!! =]
Até mais!!!
  • 0

#14 Dennys Lopes

Dennys Lopes
  • Membros
  • 281 posts

Postado 23 agosto 2006 - 09:50

Função muito util na hora de criar uma pasta:

Caso voce queira criar a pasta "c:\func\vb\imasters" e não existe nenhuma dessas pastas, nem a func, ao inves de criar uma por uma usando o MKDIR, jogue esse caminho nessa funcao:

Public Function NewPath(path As String) As String
Dim QuebraPasta As Variant
Dim CriaPasta As String
Dim cont As Integer
Dim QuebraParametro As Variant

On Error GoTo trata

If Right(path, 1) = "\" Then path = Left(path, Len(path) - 1)

If FileExist(path) = False Then
	QuebraPasta = Split(path, "\")
	For cont = 1 To UBound(QuebraPasta)
		If cont = UBound(QuebraPasta) Then
			QuebraParametro = Split(QuebraPasta(cont), ";")
			If cont = 1 Then
				CriaPasta = QuebraPasta(0) & "\" & QuebraParametro(0)
			Else
				CriaPasta = CriaPasta & "\" & QuebraParametro(0)
			End If
		Else
			If CriaPasta = "" Then
				CriaPasta = QuebraPasta(cont - 1) & "\" & QuebraPasta(cont)
			Else
				CriaPasta = CriaPasta & "\" & QuebraPasta(cont)
			End If
		End If
		If Not FileExist(CriaPasta) Then MkDir (CriaPasta)
	Next cont
End If

trata:
If Err.Number = 76 Or Err.Number = 75 Then
	Resume Next
ElseIf Err.Number <> 0 Then
	MsgBox Err.Number & " - " & Err.Description, vbCritical
End If
End Function

  • 0

#15 slype

slype
  • Membros
  • 99 posts

Postado 03 setembro 2006 - 02:11

Tai mais uma de minhas Subs...
essa é show de bola, quebra um galhão nos meus sistemas...

• Serve para carregar um ComboBox com Informações (baseado no parametro (Tipo) que você passa)
• Vcs podem colocar mais coisas nela... é só seguir o eskema:

Public Sub DadosCBO(Cb As ComboBox, Tipo As String, Optional NumIni As Double, Optional NumFim As Double)
	Cb.Clear
	Tipo = LCase(Tipo)
	Select Case Tipo
		Case "meses"
			Cb.AddItem "Janeiro"
			Cb.AddItem "Fevereiro"
			Cb.AddItem "Março"
			Cb.AddItem "Abril"
			Cb.AddItem "Maio"
			Cb.AddItem "Junho"
			Cb.AddItem "Julho"
			Cb.AddItem "Agosto"
			Cb.AddItem "Setembro"
			Cb.AddItem "Outubro"
			Cb.AddItem "Novembro"
			Cb.AddItem "Dezembro"
		Case "diasemana"
			Cb.AddItem "Domingo"
			Cb.AddItem "Segunda"
			Cb.AddItem "Terça"
			Cb.AddItem "Quarta"
			Cb.AddItem "Quinta"
			Cb.AddItem "---ta"
			Cb.AddItem "Sábado"
		Case "numeros"
			Do While NumIni <= NumFim
				Cb.AddItem NumIni
				NumIni = NumIni + 1
			Loop
		Case "estados"
			Cb.AddItem "AC"
			Cb.AddItem "AL"
			Cb.AddItem "AM"
			Cb.AddItem "AP"
			Cb.AddItem "BA"
			Cb.AddItem "CE"
			Cb.AddItem "DF"
			Cb.AddItem "ES"
			Cb.AddItem "GO"
			Cb.AddItem "MA"
			Cb.AddItem "MG"
			Cb.AddItem "MS"
			Cb.AddItem "MT"
			Cb.AddItem "PA"
			Cb.AddItem "PB"
			Cb.AddItem "PE"
			Cb.AddItem "PI"
			Cb.AddItem "PR"
			Cb.AddItem "RJ"
			Cb.AddItem "RN"
			Cb.AddItem "RO"
			Cb.AddItem "RR"
			Cb.AddItem "RS"
			Cb.AddItem "SC"
			Cb.AddItem "SE"
			Cb.AddItem "SP"
			Cb.AddItem "TO"
		Case "impressoras"
			For Each ImprComputador In Printers
				Cb.AddItem ImprComputador.DeviceName
			Next ImprComputador
		Case "estadocivil"
			Cb.AddItem "Amasiado(a)"
			Cb.AddItem "Casado(a)"
			Cb.AddItem "Desquitado(a)"
			Cb.AddItem "Divorciado(a)"
			Cb.AddItem "Separado(a)"
			Cb.AddItem "Solteiro(a)"
			Cb.AddItem "Viúvo(a)"
			Cb.AddItem "2º União"
		Case "---o"
			Cb.AddItem "Masculino"
			Cb.AddItem "Feminino"
	End Select
End Sub

... show de bola pessoal... continuem postando!!! Até mais!
  • 0

#16 Jattobá

Jattobá
  • Membros
  • 21 posts

Postado 11 março 2007 - 21:11

Informar a data ex:

Dim as dhoje as string



dhohe = RetDia(11/03/2007)

Retorno = Domingo, 11 de Março de 2007



Public Function RetDia(qData As Date) As String

			  Dim Dia(), Mes(), lngValor As Integer

			  Dia = Array("Domingo", "Segunda-Feira", "Terça-Feira", "Quarta-Feira", "Quinta-Feira", "---ta-Feira", "Sábado")

			  lngValor = Weekday(qData)

			  Mes = Array("Janeiro", "Fevereiro", "Março", "Abril", "Maio", "Junho", _

			  "Julho", "Agosto", "Setembro", "Outubro", "Novembro", "Dezembro")

			  RetDia = Dia(lngValor) + ", " + CStr(Day(qData)) + " de " + Mes(Month(qData)) + " de " + CStr(Year(qData))

End Function

  • 0

#17 Jattobá

Jattobá
  • Membros
  • 21 posts

Postado 18 março 2007 - 00:55

Algumas vezes precisamos realizar checks, comparações etc.

Abaixo crieI uma função que me retorna se pode ou não digitar uma informação.

No exemplo abaixo verifico se um lançamento de horas é valido ou não. ( Uso horas no formato texto 00:00 a 23:59 convertidos em minutos de 0 a 1439 )



No form da digitação deixo um listbox invisivel, onde a função abaixo preenche com os parâmetros enviados.



List1 = listbox

tE1 = por exemplo : 720 , ou seja 12:00 * 60 minutos.

tS2 = por exemplo : 1080 , ou seja 18:00 * 60 minutos.

val(TxtAte.text) = o valor digitado.

Será carregado no listbox os valores entre 720 a 1080



'------------------------------------------------------------------------------------------------------------



If ChekHorasDigitadas(List1, tE1, tS2, val(TxtAte.text)) = "S" Then

   msgbox "Localizado"

  'Ok permitido

endif



'------------------------------------------------------------------------------------------------------------

Public Function ChekHorasDigitadas(ListaResu As ListBox, HTabini, HTabfim, HDigit)

	Dim a As Integer, f As Integer, I As Integer

	Dim xHoraLocalizada As Integer

	Dim Hinicial As Integer

	Dim Hfinal As Integer

		

	Hinicial = HTabini

	Hfinal = HTabfim

	

	If Hfinal < Hinicial Then

		Hfinal = Hfinal + 1440

	End If

	

	ListaResu.Clear

	For a = Hinicial To Hfinal

		If a < 1440 Then

		   ListaResu.AddItem a

		End If

		If a = 1440 Then

		   Hinicial = 0

		   Hfinal = Hfinal - 1440

		   For f = Hinicial To Hfinal

			   ListaResu.AddItem f

		   Next

		End If

	Next

	

	For I = 0 To ListaResu.ListCount - 1

		xHoraLocalizada = ListaResu.List(I)

		If xHoraLocalizada = HDigit Then

		   ChekHorasDigitadas = "S"

		   Exit Function

		Else

		   ChekHorasDigitadas = "N"

		End If

	Next

	

End Function

'------------------------------------------------------------------------------------------------------------



Utilizando a mesma lógica você pode usar a função com poucas modificação para fazer outras verificações, por exemplo :

Verificação de UF, Cidades, Numeros sequenciais ou não, e outros conforme sua imaginação.

Poderia tambem ser realizado ao invés de usar o ListBox, poderia ser usado uma Matrix(x), mas preferi dessa forma, visto que confiro todos os resultados no ato no listbox)

tenha o cuidado de não permitir o estouro do listbox ou a performance, caso o conteudo temporários do listbox seja muito extensa.

  • 0

#18 Vegeta

Vegeta
  • Membros
  • 11 posts

Postado 28 setembro 2007 - 16:08

fazer um form ficar na frente de todos, sem permitir que acesse outro form no aplicativo, tipo um msgbox!

exemplo:

'NO ENVENTO EM QUE você VAI CHAMAR O FORM

Private sub Command1_Click()
form1.show 1
end sub

  • 0

#19 Roney

Roney

    Roney

  • Membros
  • 27 posts

Postado 25 janeiro 2008 - 19:17

Aê galera, beleza?
Não sei se será útil para alguém, mas eu precisei dessa coisa e num achei em lugar nenhum. Então, depois de feito, é hora de compartilhar...

Justificar parágrafo em VB com objeto PRINTER

Você vai precisar de um arquivo de módulo. No meu caso, chamei-o de modPrinter.bas

Public Const PHYSICALHEIGHT = 111
Public Const PHYSICALWIDTH = 110
Public Const PHYSICALOFFSETX = 112
Public Const PHYSICALOFFSETY = 113

Public Type SIZE
    cx As Long
    cy As Long
End Type

Public Declare Function _
    GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
        ByVal hdc As Long, _
        ByVal lpsz As String, _
        ByVal cbString As Long, _
        lpSize As SIZE _
) As Long

Public Declare Function _
    SetTextJustification Lib "gdi32" ( _
        ByVal hdc As Long, _
        ByVal nBreakExtra As Long, _
        ByVal nBreakCount As Long _
) As Long

Public Declare Function _
    TextOut Lib "gdi32" Alias "TextOutA" ( _
        ByVal hdc As Long, _
        ByVal x As Long, _
        ByVal y As Long, _
        ByVal lpString As String, _
        ByVal nCount As Long _
) As Long

Public Declare Function _
    GetDeviceCaps Lib "gdi32" ( _
        ByVal hdc As Long, _
        ByVal nIndex As Long _
) As Long


E aqui vai o arquivo de classe, que chamei de CPrinter.cls

Option Explicit

Private m_hDC As Double
Private m_LeftMargin As Long
Private m_RightMargin As Long
Private m_LineSize As Long
Private m_LineHeight As Long


Private Function getLineSpaces(ByVal szText As String) As Long
    getLineSpaces = UBound(Split(szText, " "))
End Function


Public Property Let hdc(ByVal lngParm As Double)
    m_hDC = lngParm
End Property
Public Property Get hdc() As Double
    hdc = m_hDC
End Property


'Selectiona a impressora desejada pelo nome. Retorna o nome da impressora anteriormente selecionada
Public Function setPrinterDevice(ByVal szDeviceName) As String
    Dim sz As SIZE
    Dim lPtr As Printer
    setPrinterDevice = Printer.DeviceName
    Printer.KillDoc
    If (szDeviceName <> "") Then
        For Each lPtr In Printers
            If (lPtr.DeviceName = szDeviceName) Then
                Set Printer = lPtr
                Exit For
            End If
        Next
    End If
    m_hDC = Printer.hdc
    m_LeftMargin = GetDeviceCaps(m_hDC, PHYSICALOFFSETX)
    m_RightMargin = GetDeviceCaps(m_hDC, PHYSICALWIDTH) - (GetDeviceCaps(m_hDC, PHYSICALOFFSETX) * 2)
    m_LineSize = m_RightMargin - m_LeftMargin
    
    GetTextExtentPoint32 m_hDC, "X", 1, sz
    m_LineHeight = sz.cy
    
    Printer.Print
End Function


Public Function PrintText(ByVal szText As String)
    Dim sz As SIZE
    Dim iPos As Long
    Dim iOldPos As Long
    Dim szBuffer As String
    
    Do While (szText <> "")
        iPos = 0
        szBuffer$ = ""
        sz.cx = 0: sz.cy = 0
        Do While (sz.cx <= m_LineSize And iPos < Len(szText) And iPos <> -1)
            iOldPos = iPos
            iPos = InStr(iPos + 1, szText, " ")
            If (iPos = 0) Then
                szBuffer$ = szText$
                iPos = -1
            Else
                szBuffer$ = Left(szText$, iPos - 1)
            End If
            GetTextExtentPoint32 m_hDC, szBuffer$, Len(szBuffer$), sz
        Loop
        If (iPos = -1) Then
            szBuffer$ = szText$
            szText$ = ""
        Else
            szBuffer$ = Left$(szText$, iOldPos - 1)
            szText$ = Mid$(szText$, iOldPos + 1)
        End If
    
        If (iPos <> -1) Then
            GetTextExtentPoint32 m_hDC, szBuffer$, Len(szBuffer$), sz
            SetTextJustification m_hDC, m_LineSize - sz.cx, getLineSpaces(szBuffer$)
        Else
            SetTextJustification m_hDC, 0, 0
        End If
        TextOut m_hDC, 0, Printer.CurrentY, szBuffer$, Len(szBuffer$)
        SetTextJustification m_hDC, 0, 0
        Printer.CurrentY = Printer.CurrentY + sz.cy
    Loop
End Function

Public Sub newLine(Optional ByVal intLines As Integer = 1)
    Printer.CurrentX = 0
    Printer.CurrentY = Printer.CurrentY + (m_LineHeight * intLines)
End Sub

Public Sub EndDoc()
    Printer.EndDoc
End Sub

E agora, um exemplo de utilização. Crie um form e coloque um botão no mesmo. No evento de click do botão, coloque algo como isto:

Private Sub Command2_Click()
    Dim oPtr As New CPrinter
    Dim szBuffer As String
    
    'Seleciona a impressora desejada
    oPtr.setPrinterDevice "" 'Sem informar nada, assume a impressora padrão configurada
    
    szBuffer = "Coloque qualquer texto aqui. A função PrintText quebra as linhas e justifica para você"
    oPtr.PrintText szBuffer$
    
    'A função newLine salta um determinado número de linhas. Quando não for informado o número, assume o padrão de saltar 1 linha.
    'IMPORTANTE: A função PrintText já salta para a próxima linha. Utilize newLine apenas para saltar mais linhas

    oPtr.newLine     'Salta 1 linha
    oPtr.newLine 1  'Salta 1 linha
    oPtr.newLine 5  'Salta 5 linhas
    
    szBuffer$ = "Coloque qualquer outro texto aqui"
    oPtr.PrintText szBuffer$
    
    Printer.EndDoc 'Finaliza impressão e despeja para a impressora
End Sub

É isso aê... espero ter ajudado alguém. Funcionou direitinho em uma HP DeskJet, em uma HP Laserjet e jogando para PDF via Easy PDF Creator.
Abs,
Roney

Editado por Claudio Neto, 27 julho 2009 - 15:29 .
Trocadas tags <div> por [code] para deixar padronizado

  • 0

#20 gabrieldb

gabrieldb

    Si Vis Pacem, Para Bellum

  • Membros
  • 286 posts

Postado 21 julho 2009 - 09:35

Criando uma aplicação em 3 camadas.

http://www.macoratti.net/vb_3cam.htm
http://www.macoratti.net/vb_3cam2.htm
http://www.macoratti.net/vb_3cam3.htm
  • 1




Publicidade

/ins>