Keskustelu: Ohjelmointikysymykset: VBA: VB6 ja Excel 2010 luku, kirjoitus ongelma

ismo [26.11.2011 16:53:58]

Ohjelmani eivät lue eikä kirjoita Excel 2010 versioon vaikka toimivat vanhemmissa Exceleissä.
Ohjelma on toteutettu siten että Label on linkitetty Excelin soluun.

Olisiko jollain tietoa miten saan toimimaan tämän?
Vai joudunko muuttamaan ohjelmat erilailla tehdyiksi, joka on ehkä aika iso homma koska niitä on 5 eri ohjelmaa ja API:t ei ole oikein hanskassa.

Käyttiksenä on XP SP3

neau33 [01.12.2011 01:32:00]

Moi ismo!

Oletko linkittänyt Excel solun VB6'n Label kontrolliin käyttämällä Excel 2010'ssä Muokkaa/Kopio ja sitten VB6'ssa Edit/Paste Link toimintoa? Mikäli näin niin avaa Excel 2010'ssä valikkoriviltä Tiedosto->Asetukset->Lisäasetukset, poista valinta: Ohita muut sovellukset, jotka käyttävät DDE (Dynamic Data Exchange) -yhteyttä ja klikkaa OK-nappia.

ismo [04.12.2011 06:38:56]

Moi neau33

Teen sen linkityksen koodilla,
mutta voisin testata Maanantaina, jos en pääse testaamaan tänään, tuota sinun ohjettasi, että auttaisiko tähän ongelmaan.

Tässä kuitenkin koodi:

Formin loadissa on polut ja Excelin nimi. Taulukon polku ja nimi eivät saa sisältää välilyöntejä. Excelin polku saa sisältää välilyöntejä.
Formille Label1, Command1, kaksi timeriä joiden Enablet Falseksi ja Intervalliksi 1
Excelin soluun A1 jotain tekstiä.
Excel 2010:ssä Commandia pitää painaa kahdesti että toimisi edes jotenkuten, mutta ei lue taulukkoa.

Const NONE = 0
Const LINMANUAL = 2
Dim PolkuA As String
Dim PolkuE As String
Sub LuoLinkki()

 Label1.LinkMode = NONE
 Label1.LinkTopic = "Excel|" + PolkuA
 Label1.LinkItem = "R2C2"
 Label1.LinkMode = LINMANUAL
 Label1.LinkRequest

End Sub

Sub KayExcel(EOExc, Link As Control)

 Dim sStartCmd As String

 On Error GoTo EOExcOn1
 If Dir$(PolkuE + "EXCEL.EXE") = "" Then EOExc = EOExc + 1
 On Error GoTo EOExcOn2
 If Dir$(PolkuA) = "" Then EOExc = EOExc + 3
 sStartCmd = PolkuE + "EXCEL.EXE " + PolkuA
 If EOExc = 0 Then h = Shell(sStartCmd, 7)

Exit Sub

EOExcOn1:
 EOExc = EOExc + 1
 Resume Next

EOExcOn2:
 EOExc = EOExc + 3
 Resume Next

End Sub

Private Sub Command1_Click()
Timer1.Enabled = True

End Sub

Private Sub Form_Load()

'Taulukon polku ja nimi
 PolkuA = "C:\a.xls"
'Excelin polku
 PolkuE = "C:\Program Files\Microsoft Office\Office14\"

End Sub

Private Sub Timer1_Timer()
 Timer1.Enabled = False

 'Haetaan ruudukko R2C2
 On Error Resume Next
 LuoLinkki
 If Err = 286 Then MsgBox "Ota kursori pois Excelin taulukosta, koska taulukkoa ei voi lukea kun se on siinä. Toisinsanoen paina Excelin taulukossa Enter.", 48: Exit Sub

 Timer2.Enabled = True
End Sub

Private Sub Timer2_Timer()
 Timer2.Enabled = False
 On Error Resume Next
 MuitaErroreita = 0

 LuoLinkki

'Käynnistetään Excel, jos ei ole jo käynnissä
'Haetaan ruudukko R2C2
 EOExc = 0
 If Err = 282 Then
 KayExcel EOExc, Label1
   If EOExc = 1 Or EOExc = 2 Then MsgBox "Sinulla ei ole Exceliä tai sen polku on annettu väärin." + Chr$(13) + Chr$(10) + "tai liikaa ohjelmia auki ( Sammuta esim. Excelit )" + Chr$(13) + Chr$(10) + "tai käynnistä Excel ja taulukko käsin. ( Ei aukea tällä ohjelmalla )", 16: Exit Sub
   If EOExc = 3 Or EOExc = 6 Then: MsgBox "Sinulla ei ole taulukkoa tai sen nimi on annettu väärin tai liikaa ohjelmia auki ( Sammuta esim. Excelit )" + Chr$(13) + Chr$(10) + "tai käynnistä Excel ja taulukko käsin. ( Ei aukea tällä ohjelmalla )", 16: Exit Sub
   If EOExc = 4 Or EOExc = 5 Or EOExc = 7 Or EOExc = 8 Then MsgBox "Sinulla ei ole taulukkoa tai Exceliä tai sen polku on annettu väärin." + Chr$(13) + Chr$(10) + "tai liikaa ohjelmia auki ( Sammuta esim. Excelit )" + Chr$(13) + Chr$(10) + "tai käynnistä Excel ja taulukko käsin. ( Ei aukea tällä ohjelmalla )", 16: Exit Sub
   On Error GoTo Label1Err
   LuoLinkki
 End If

Hae:
 On Error Resume Next

'EXCELIN KÄSITTELY
 Label1.Caption = ""
 Label1.LinkItem = "R1C1": Label1.LinkRequest
 MsgBox "A1 solun arvo = " + Label1.Caption

 Label1.Caption = "TÄMÄ TEKSTI SIJOITETAAN SOLUUN B2"
 Label1.LinkItem = "R2C2"
 Label1.LinkPoke
 MsgBox "Solussa B2 pitäisi olla tekstiä"

Exit Sub
'********

Label1Err:
 Resume Label1Err2

Label1Err2:
 MuitaErroreita = MuitaErroreita + 1
 If MuitaErroreita > 1000 Then GoTo MuitaErroreita2
 LuoLinkki
 GoTo Hae

MuitaErroreita2:
 On Error Resume Next
 MsgBox "Tuntematon virhe." + Chr$(13) + Chr$(10) + "Taulukon sijainti esim. verkossa, työpöydällä tai muualla erikoisemmassa paikassa aiheuttaa että sitä ei saatu auki." + Chr$(13) + Chr$(10) + "Kopioi taulukko jonnekin muualle" + Chr$(13) + Chr$(10) + "tai käynnistä Excel ja taulukko käsin. ( Ei aukea tällä ohjelmalla )", 16
 MsgBox "Myös tiedoston nimessä olevat erikois merkit (ainakin välilyönnit) aiheuttavat virheen." + Chr$(13) + Chr$(10) + "Sammuta tämä ohjelma, korjaa tiedoston nimi ja käynnistä tämä ohjelma uudestaan.", 16

End Sub

ismo [04.12.2011 14:34:19]

Siitä DDE:stä oli ruksi pois.
Kokeilin ohjelmaa laittamalla ruksin siihen, mutta se ei auttanut.

neau33 [06.12.2011 07:25:56]

Moi ismo!

Koodisi on sen verran sekavaa, etten ala sitä tässä erikseen erittelemään tai arvostelemaan.
Aikalailla ihmettyttää kuitenkin Timer-objektien käyttö, koska DDE:n avulla linkitettyjen objektien automaattinen päivittyminen ei niitä tarvitse. Vieläkin enemmän ihmetyttää Excel tiedoston mahdollisen avoinna olon tutkiminen Timer-tapahtuman sisällä, jonka intervall-arvoksi kerrot määrittäneesi 1:n millisekunnin?

Elikäs yksinkertaisimmillaan voisit tehdä niin, että avaat VB6:n ja luot uuden Standard EXE -projektin. Sitten raahaat lomakkeelle yhden Label sekä yhden Text-kontrollin. Avaat jonkin luomasi Excel-työkirjan, aktivoit esim. laskentataulukon Taul1 solun A1, valitset Excelin muokkaa valikosta valinnan Kopioi, aktivoit VB6-projektisi Label-kontrollin hiirellä ja valitset Edit valikosta valinnan Paste link. Nyt kun ajat VB6-projektisi niin Label-kontrolli päivittyy automaattisesti aina, kun muutat ko. solun arvoa Excelissä. Jos tahdot muuttaa solun arvoa VB6-projektista käsin niin voisit laittaa esim. Text1-kontrollin KeyUp tapahtumaan seuraavanlaisen koodinpätkän...

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
   If KeyCode = 13 Then
      On Error Resume Next
      Label1.LinkMode = 2
      Label1.Caption = Text1.Text
      Label1.LinkPoke
      Label1.LinkMode = 1
      If Err <> 0 Then
         MsgBox Error$
         Err.Clear: On Error GoTo 0
      End If
      Text1.Text = ""
   End If
End Sub

Tässä vielä vaihtoehto DDE-linkitykselle

Private xlApp, xlBook, xlSheet
Private xlPath As String

Private Sub Form_Load()

   Set xlApp = Nothing
   Set xlBook = Nothing
   Set xlSheet = Nothing

   On Error Resume Next
   'Jos Excel on käynnissä niin Excel.Application
   'objekti voidaan luoda GetObject funktion avulla
   Set xlApp = GetObject(, "Excel.Application")

   'Mikäli ei ollut käynnissä niin syntyi virhe jolloin
   'Excel.Application objektin luomista voidaan yrittää
   'virheenkäsittelyn jälkeen CreateObject funktion avulla
   If Err <> 0 Then
      Err.Clear: On Error GoTo 0
      On Error Resume Next
      Set xlApp = CreateObject("Excel.Application")
      If Err <> 0 Then
         Err.Clear: On Error GoTo 0
      End If
   End If

   If xlApp Is Nothing Then
      MsgBox "Microsoft Excel ei ole asennettuna järjestelmään"
      Exit Sub
   Else
      xlApp.Visible = True
      xlPath = "C:\testi\testi.xls" 'esim.
      If xlApp.Workbooks.Count > 0 Then
         Dim tmpBook
         For Each tmpBook In xlApp.Workbooks
            With tmpBook
               If .FullName = xlPath Then
                  Set xlBook = tmpBook: Exit For
               End If
            End With
         Next
      End If
   End If

   If xlBook Is Nothing Then
      If Dir(xlPath) <> "" Then
         Set xlBook = xlApp.Workbooks.Open(xlPath)
      Else
         MsgBox "Tiedostoa '" & xlPath & "' ei löydy"
         Exit Sub
      End If
   End If

   On Error Resume Next
   Set xlSheet = xlBook.Worksheets("Taul1")
   If Err <> 0 Then
      MsgBox Error$
      Err.Clear
      On Error GoTo 0
   End If

   If Not xlSheet Is Nothing Then
      Timer1.Interval = 250 'esim.
      Timer1.Enabled = True
   End If

End Sub

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)

   'Enter-nappin painamisen jälkeen
   If KeyCode = 13 Then
      If Not xlSheet Is Nothing Then
         xlSheet.Cells(1, 1).Value = Text1.Text
      End If
   End If

End Sub

Private Sub Timer1_Timer()

   On Error Resume Next
   If xlSheet.Cells(1, 1).Text <> Label1.Caption Then
      Label1.Caption = xlSheet.Cells(1, 1).Text
   End If
   If Err <> 0 Then
      Err.Clear
      On Error GoTo 0
   End If

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

   Timer1.Enabled = False

   On Error Resume Next
   xlApp.DisplayAlerts = False
   xlBook.Save
   xlApp.Quit

   Set xlSheet = Nothing
   Set xlBook = Nothing
   Set xlApp = Nothing

End Sub

Ja tässä esimerkki tiedosnsiirrosta leikepöydän avulla

VB6-Projekti:

'Form1
Private TagValue As String, xlApp

Private Sub Form_Load()

   Set xlApp = Nothing
   Dim xlPath As String
   xlPath = Environ("userprofile") & "\Työpöytä\testi.xls"

   On Error Resume Next
   Set xlApp = GetObject(, "Excel.Application")
   If Err <> 0 Then
      Err.Clear: On Error GoTo 0
      On Error Resume Next
      Set xlApp = CreateObject("Excel.Application")
      If Err <> 0 Then
         Err.Clear: On Error GoTo 0
         MsgBox "Microsoft Excel ei ole asennettu järjestelmään!"
      End If
   End If

   If Not xlApp Is Nothing Then

      xlApp.Visible = True

      If xlApp.Workbooks.Count > 0 Then

         Dim xlBook

         For Each xlBook In xlApp.Workbook
            With xlBook
               If .FullName = xlPath Then
                  IsOpen = True: Exit For
               End If
            End With
         Next

         If Not IsOpen Then
            xlApp.Workbooks.Open xlPath
         End If
      Else
         xlApp.Workbooks.Open xlPath
      End If

      Timer1.Interval = 250
      Timer1.Enabled = True

   End If

End Sub

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)

   If KeyCode = 13 Then
      Clipboard.Clear
      Label1.Caption = Text1.Text
      Clipboard.SetText "#vbdata#" & Label1.Caption
      Text1.Text = ""
   End If

End Sub

Private Sub Timer1_Timer()

   Dim Clip As String
   On Error Resume Next
   Clip = Clipboard.GetText

   If InStr(Clip, "#xldata#") > 0 Then
      TagValue = Replace(Clip, "#xldata#", "")
      If TagValue <> Label1.Caption Then
         Label1.Caption = TagValue
      End If
   End If

   If Err <> 0 Then
      Err.Clear
      On Error GoTo 0
   End If

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

   If Not xlApp Is Nothing Then
      xlApp.DisplayAlerts = False
      xlApp.Quit
      Set xlApp = Nothing
   End If

End Sub

VBA-Projekti:

'Module1:
Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Public IsRunning As Boolean
Private TagValue As String

'Referenssi:
'Mirosoft Forms 2.0 Object Library
'(C:\Windows\System32\FM20.dll)
Private Clip As New MSForms.DataObject

Sub auto_open()

   MainLoop
   IsRunnin = True

End Sub

Public Sub MainLoop()

   Dim temp As String

   Do: DoEvents

      If Sheets("Taul1").Cells(1, 1).Text <> TagValue Then
         TagValue = Sheets("Taul1").Cells(1, 1).Text
         Clip.SetText "#xldata#" & TagValue
         Clip.PutInClipboard
         Clip.Clear
      Else
         On Error Resume Next
         Clip.GetFromClipboard
         temp = Clip.GetText
         Clip.Clear
         If Left(temp, 8) = "#vbdata#" Then
            temp = Replace(temp, "#vbdata#", "")
            If temp <> Sheets("Taul1").Cells(1, 1).Text Then
               Sheets("Taul1").Cells(1, 1).Value = temp
               TagValue = Sheets("Taul1").Cells(1, 1).Text
            End If
         End If

      End If
      If Err <> 0 Then
         Err.Clear: On Error GoTo 0
      End If
   Sleep 250: Loop

End Sub

'Taul1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   If Not IsRunning Then
      auto_open
   End If

End Sub

neau33 [07.12.2011 07:25:29]

Moi taas ismo!

Tässä vielä eräs melko extreme tapa hoidella VB6 <-> Excel tiedonsiirtoa...

HUOM! Excelissä Työkalut->Makro->Suojaus->Luotettavat julkaisijat välinlehdellä
valinnan Luota Visual Basic projektiin tulee olla valittuna

'VB6-Projekti
Dim xlApp, xlBook, xlModule

Private Sub Form_Load()

   Dim xlName As String, xlPath As String
   xlName = "test.xls"
   xlPath = Environ("USERPROFILE") & "\Työpöytä\" & xlName

   Set xlApp = GetExcel(xlPath)

   If Not xlApp Is Nothing Then

      On Error Resume Next

      If xlApp.Workbooks.Count = 0 Then
         Set xlBook = xlApp.Workbooks.Add
         xlBook.SaveAs xlPath
      Else
         Set xlBook = xlApp.Workbooks(xlName)
      End If

      For Each xlModule In xlBook.VBProject.VBComponents
         With xlModule
            If Left(.Name, 6) = "Module" Then
               xlBook.VBProject.VBComponents.Remove (xlModule)
            End If
         End With
      Next

      If Err <> 0 Then

         If Err = 92 Then
            MsgBox "Tarkista Työkalut valikosta Makro -> Suojaus " & _
            vbCr & "Luotettavat julkaisijat -välilehden asetusten tila" & _
            vbCr & "tarvittaessa aktivoi Luota Visual Basic projektiin", _
            vbCritical, xlApp.Name
            Err.Clear: Unload Me
         End If

         MsgBox Error$
         Err.Clear: On Error GoTo 0
         Exit Sub

      End If

      Set xlModule = xlBook.VBProject.VBComponents.Add(1)

      Dim strCode As String
      strCode = "Function GetValue() As String" & vbCr _
      & "   GetValue = ActiveSheet.Cells(1,1).Text " _
      & vbCr & "End Function"
      xlModule.CodeModule.AddFromString strCode

      strCode = "Sub SetValue(StrValue As String) " & vbCr _
      & "   ActiveSheet.Cells(1,1).value = StrValue" _
      & vbCr & "End Sub"
      xlModule.CodeModule.AddFromString strCode

      Timer1.Interval = 200
      Timer1.Enabled = True

   Else

      MsgBox "Microsoft Excel ei ole asennettu - Ohjelma suljetaan!"
      Unload Me

   End If

End Sub

Function GetExcel(ByVal xlPath As String) As Object

   Dim xlTemp: Set xlTemp = Nothing

   On Error Resume Next
   Set xlTemp = GetObject(, "Excel.Application")
   If Err <> 0 Then
      Err.Clear
      On Error Resume Next
      Set xlTemp = CreateObject("Excel.Application")
      xlTemp.Visible = True
      xlTemp.Workbooks.Open xlPath
   Else
      Dim IsExisting As Boolean
      xlTemp.Workbooks.Open xlPath
      xlTemp.DisplayAlerts = False
      For Each xlBook In xlTemp.Workbooks
         With xlBook
            If .FullName <> xlPath Then
               xlBook.Close
            Else
               IsExisting = True
            End If
         End With
      Next

      xlTemp.DisplayAlerts = True

      If Not IsExisting Then
         xlTemp.Workbooks.Open xlPath
      End If

   End If

   If Err <> 0 Then
      Err.Clear: On Error GoTo 0
   End If

   Set GetExcel = xlTemp: Set xlTemp = Nothing

End Function

Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)

   If KeyCode = 13 Then
      On Error Resume Next
      xlApp.Run "SetValue", Text1.Text
      If Err <> 0 Then
         Err.Clear: On Error GoTo 0
      End If
      Text1.Text = ""
   End If

End Sub

Private Sub Timer1_Timer()

   On Error Resume Next
   Label1.Caption = xlApp.Run("GetValue")
   If Err <> 0 Then
      If Err = 1004 Then
         MsgBox "Excel ei vastaa - Ohjelma suljetaan!"
         Unload Me
      End If
      Err.Clear: On Error GoTo 0
   End If

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

   On Error Resume Next
   Timer1.Enabled = False
   xlBook.VBProject.VBComponents.Remove (xlModule)
   xlApp.DisplayAlerts = False
   xlBook.Save: xlApp.Quit
   Set xlModule = Nothing
   Set xlBook = Nothing
   Set xlApp = Nothing

End Sub

Halutessaan valmiin +viritelmän voi ladata täältä

ismo [07.12.2011 18:02:14]

Nea.

Joo sekava on.
Aikoja sitten olen tämän jostain kopioinut ja kun on toiminut niin olen sitä viljellyt aina uusiin ohjelmiin.

Käsittelen 300 rivisiä tiedostoja, joten tuo esimerkki pätkäni on lyhennelty versio, koska täyspitkä Excelin käsittely olisi vielä sekavamman näköinen.

Mutta kiitoksia, kunhan pääsen tästä kotia, niin varmaan noista sinun esimerkeistä pystyn muokkaamaan oikeanlaisen käsittelyn.

t.Ismo

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät

Kilpailu