não sei quase que nada de vba e preciso muito da ajuda de voces.
tenho uma macro que ao termino do preenchimento de um formulario ela gera um documento em word, so que este documento esta saindo desconfigurado, as perguntas umas saem em negrito e outras não e assim vai.
Ao termino ele também cria este documento por da um erra "460" e aponta para o local onde esta endereçado o cod.
podem me ajudar por fvr.
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private wsSuporte As Worksheet
Dim GetUserN
Dim ObjNetwork
'Declarações
Dim appWord As Variant
Dim doc As Variant
Dim stCabc As String
Dim prg As Variant
Dim rng As Variant
Sub CriarDocumento()
Set wsSuporte = ThisWorkbook.Worksheets("SUPORTE")
Question
POLIVEIRA
Galera,
não sei quase que nada de vba e preciso muito da ajuda de voces.
tenho uma macro que ao termino do preenchimento de um formulario ela gera um documento em word, so que este documento esta saindo desconfigurado, as perguntas umas saem em negrito e outras não e assim vai.
Ao termino ele também cria este documento por da um erra "460" e aponta para o local onde esta endereçado o cod.
podem me ajudar por fvr.
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private wsSuporte As Worksheet
Dim GetUserN
Dim ObjNetwork
'Declarações
Dim appWord As Variant
Dim doc As Variant
Dim stCabc As String
Dim prg As Variant
Dim rng As Variant
Sub CriarDocumento()
Set wsSuporte = ThisWorkbook.Worksheets("SUPORTE")
'limpar area de transferência
Call JustEmptyClipboard
'Declarações
Dim stPrg1 As String
'INICIO SELEÇÃO
stPrg1 = wsSuporte.Range("A9").Text '---> "G9"
Dim myRang As String
Dim stNome As String
Dim stRcl As String
Dim intLin As Integer
Dim intLimite As Integer
stNome = Worksheets("SUPORTE").Range("A9").Text ' -> ("C19")
'A Aplicação é criada aqui:
Set appWord = CreateObject("Word.Application")
'A linha abaixo é importante: você deve querer que
'sua aplicação seja visível na maioria das vezes
appWord.Visible = True
'Note que, na linha abaixo, foi adicionado um Documento
'dentro da Aplicação appWord:
Set doc = appWord.Documents.Add
'Da mesma forma, é atribuído ao Parágrafo prg o primeiro
'parágrafo existente do Documento doc.
Set prg = doc.Paragraphs(1)
'Dimencionar Margens da pagina
doc.PageSetup.TopMargin = Application.CentimetersToPoints(2.5)
doc.PageSetup.BottomMargin = Application.CentimetersToPoints(2.5)
doc.PageSetup.LeftMargin = Application.CentimetersToPoints(3)
doc.PageSetup.RightMargin = Application.CentimetersToPoints(3)
doc.PageSetup.HeaderDistance = Application.CentimetersToPoints(1.25)
doc.PageSetup.FooterDistance = Application.CentimetersToPoints(1.25)
'Abre Cabeçalho
doc.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
'Alinha logo ao centro
doc.ActiveWindow.ActivePane.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
'Formata Fonte
doc.ActiveWindow.ActivePane.Selection.Font.Size = 10
doc.ActiveWindow.ActivePane.Selection.Font.Bold = wdToggle
doc.ActiveWindow.ActivePane.Selection.Font.Italic = wdToggle
doc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
doc.ActiveWindow.View.DisplayPageBoundaries = False
'Insere texto 1º paragrafo
doc.ActiveWindow.Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
prg.Range.Text = stPrg1
doc.ActiveWindow.Selection.MoveDown Unit:=wdScreen
doc.ActiveWindow.Selection.EndKey Unit:=wdLine
Set rng = prg.Range
With rng.Font
.Bold = False
.Name = "Arial"
.Size = 12
.Color = wdColorAutomatic 'TESTE DE TROCA DE COR .Color = wdColorDarkTeal
End With
If frmDadosFormulario.optCFolha.Value = True Then
intLimite = 325 ' intLimite = 325
Else
intLimite = 118 'intLimite = 118
End If
For intLin = 9 To intLimite
stPrg1 = wsSuporte.Range("A" & intLin).Text ' -----> "G"
If stPrg1 = "Em Branco" Then
doc.ActiveWindow.Selection.TypeParagraph
Else
If intLin > 9 Then
doc.ActiveWindow.Selection.TypeParagraph
doc.ActiveWindow.Selection.Range.Text = stPrg1
doc.ActiveWindow.Selection.MoveDown Unit:=wdScreen
doc.ActiveWindow.Selection.EndKey Unit:=wdLine
End If
End If
Next
Call DestaqueEmNegrito
Set ObjNetwork = CreateObject("WScript.Network")
GetUserN = ObjNetwork.UserName
UsuarioRede = GetUserN
Dim stNomeArq As String
Dim Resposta As Integer
Resposta = MsgBox("Verique o conteudo da carta, se estiver de acordo clique em Sim", vbExclamation + vbYesNo, "ATENÇÃO!")
If Resposta <> 6 Then
MsgBox "O documento não será salvo, você poderá reeditar no auto carta ou no próprio documento", vbInformation, "Atenção!"
Exit Sub
Else
stNomeArq = InputBox("O documento será salvo em sua área de trabalho, Insira o nome do documento!")
''Salvar Como':
doc.SaveAs Filename:="C:\Documents and Settings\" & UsuarioRede & "\Desktop\" & stNomeArq & ".doc", FileFormat:=wdFormatXMLDocument
'FileFormat:=wdFormatXMLDocument significa que o arquivo será salvo com a
'extensão .doc, ou seja, Documento do Word 2003.
'Agora, deseja-se sair da Aplicação. Observe que o método é executado
'no nível da Aplicação, finalizando a Aplicação e todos os objetos
'criados por ela:
appWord.Quit
End If
'Apenas para limpar memória
Set appWord = Nothing
Set doc = Nothing
Set prg = Nothing
Set ObjNetwork = Nothing
End Sub
Sub JustEmptyClipboard()
OpenClipboard (0)
EmptyClipboard
CloseClipboard
End Sub
Sub LimparCarta()
Worksheets("SUPORTE").Range("C14:C42").ClearContents
Worksheets("SUPORTE").Range("C49:C58").ClearContents
Worksheets("SUPORTE").Range("C61:C67").ClearContents
Worksheets("SUPORTE").Range("C70:C76").ClearContents
Worksheets("SUPORTE").Range("C79:C82").ClearContents
Worksheets("SUPORTE").Range("C85:C109").ClearContents
Worksheets("SUPORTE").Range("C112:C121").ClearContents
Worksheets("SUPORTE").Range("C124:C129").ClearContents
Worksheets("SUPORTE").Range("C132:C148").ClearContents
Worksheets("SUPORTE").Range("C151:C162").ClearContents
Worksheets("SUPORTE").Range("C171:C184").ClearContents
Worksheets("SUPORTE").Range("C187:C198").ClearContents
Worksheets("SUPORTE").Range("C201:C212").ClearContents
Worksheets("SUPORTE").Range("C215:C219").ClearContents
Worksheets("SUPORTE").Range("C222:C231").ClearContents
Worksheets("SUPORTE").Range("C234:C242").ClearContents
Worksheets("SUPORTE").Range("C247:C254").ClearContents
Worksheets("SUPORTE").Range("C257:C270").ClearContents
Worksheets("SUPORTE").Range("C273:C277").ClearContents
Worksheets("SUPORTE").Range("C280:C292").ClearContents
Worksheets("SUPORTE").Range("C299:C310").ClearContents
Worksheets("SUPORTE").Range("C313:C316").ClearContents
End Sub
Sub DestaqueEmNegrito()
Set wsSuporte = ThisWorkbook.Worksheets("SUPORTE")
Dim strNgrt As String
Dim intCel As Integer
For intCel = 1 To 325 '-> For intCel = 1 To 325
strNgrt = wsSuporte.Range("Q" & intCel).Text ' -> strNgrt = wsSuporte.Range("Q" & intCel).Text
doc.ActiveWindow.Selection.Find.ClearFormatting
With doc.ActiveWindow.Selection.Find
.Text = strNgrt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
doc.ActiveWindow.Selection.Find.Execute
doc.ActiveWindow.Selection.Font.Bold = True
If intCel > 2 And intCel < 19 Then '-------> If intCel > 2 And intCel < 19 Then
doc.ActiveWindow.Selection.Font.Underline = wdUnderlineSingle
End If
Next
intCel = 0
For intCel = 1 To 22 '-> For intCel = 1 To 12
strNgrt = wsSuporte.Range("R" & intCel).Text '-> strNgrt = wsSuporte.Range("R" & intCel).Text
doc.ActiveWindow.Selection.Find.ClearFormatting
With doc.ActiveWindow.Selection.Find
.Text = strNgrt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
doc.ActiveWindow.Selection.Find.Execute
doc.ActiveWindow.Selection.Font.Underline = wdUnderlineSingle
Next
intCel = 0
For intCel = 1 To 22 ' -> For intCel = 1 To 12
strNgrt = wsSuporte.Range("S" & intCel).Text ' -> strNgrt = wsSuporte.Range("S" & intCel).Text
doc.ActiveWindow.Selection.Find.ClearFormatting
With doc.ActiveWindow.Selection.Find
.Text = strNgrt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
doc.ActiveWindow.Selection.Find.Execute
doc.ActiveWindow.Selection.Font.Underline = wdUnderlineNone
doc.ActiveWindow.Selection.Font.Color = 16724787
Next
'---Centralizar
If frmDadosFormulario.optCFolha.Value = True Then
intCel = 0
For intCel = 1 To 3
strNgrt = wsSuporte.Range("Y" & intCel).Text ' -> strNgrt = wsSuporte.Range("Y" & intCel).Text
doc.ActiveWindow.Selection.Find.ClearFormatting
With doc.ActiveWindow.Selection.Find
.Text = strNgrt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
doc.ActiveWindow.Selection.Find.Execute
doc.ActiveWindow.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
If strNgrt = "DADOS CLIENTE E PROCESSO" Then
doc.ActiveWindow.Selection.ParagraphFormat.SpaceBefore = 12
doc.ActiveWindow.Selection.ParagraphFormat.SpaceAfter = 3
End If
Next
Else
strNgrt = wsSuporte.Range("Y3").Text '-> strNgrt = wsSuporte.Range("Y3").Text
doc.ActiveWindow.Selection.Find.ClearFormatting
With doc.ActiveWindow.Selection.Find
.Text = strNgrt
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
doc.ActiveWindow.Selection.Find.Execute
doc.ActiveWindow.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End If
End Sub
Sub Desproteger()
Worksheets("SUPORTE").Visible = xlSheetVisible
End Sub
Sub Form()
fmrBusca.Show
End Sub
Link to comment
Share on other sites
0 answers to this question
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.